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A1TEST.M0D 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


MODULE allocltest; 

FROM Alloci IMPORT bIockPtr, allocate, free, setWord, getWord, blockSize, 
getFreeList; 

FROM MyTerminal IMPORT WriteString, Write, WriteLnString, WriteLn, 

WriteCard, fatal, pause, ClearScreen, Read; 

FROM SYSTEM IMPORT WORD, ADDRESS; 

FROM InOut IMPORT ReadCard; 

FROM MachineSpecific IMPORT writeAddress; 

CONST maxlndex = 32767; 

TYPE bPtr « POINTER TO block; 
block = RECORD 

size;CARDINAL; 

CASE BOOLEAN OF 

TRUE: nextBlock: bPtr; 

| FALSE: contents:ARRAY[0..maxlndex] OF WORD; 

END; 

END; 

VAR bIockList:ARRAY[• a *.. • z ' ] OF blockPtr; 

PROCEDURE rawPrintBIockHeader(bIockp:bPtr); 

BEGIN 

WrlteLnStr ing("-'•); 

IF ADDRESS(blockp) « NIL THEN 
WriteLnString("NIL"); 

ELSE 

WriteString("BIock (raw) "); 
writeAddress(ADDRESS(bIockp)); 

WriteString( M (-)• 

WriteCard(blockp*.size, 0); 

Wr iteLnStr ing(" words)"); 

END; 

END rawPrintBIockHeader; 

PROCEDURE rawPrintBIock(bIockp:bPtr); 

VAR I:CARDINAL; 

BEGIN 

rawPrintBIockHeader(bIockp); 

IF bIockp <> NIL THEN 
WITH blockp" DO 

FOR i :* 0 TO size-1 DO 

WriteCard(i, 3); WriteString(*: ’); 

WriteCard(CARDINAL(contents[i]), 0); WriteLn; 

END; 

END; 

END; 

END rawPrintBIock; 

PROCEDURE printBIockHeader(bIockp:bIockPtr); 

BEGIN 

Wr IteLnStr i ng("-"); 

IF ADDRESS(blockp) - NIL THEN 
WriteLnString("NIL"); 

ELSE 

WriteStrIng("BIock "); 

writeAddress(ADDRESS(bIockp)); 

WriteString(" ("); 

(continued) 
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Wr'teCord(blockSize(blockp), 0); 

WritelnString(" words)"); 

ENO; 

ENO printBIockHeoder; 

PROCEDURE orintBlock(blockp:blockPtr); 

VAR i:CAROINAL; 

BEGIN 

printBIockHeoder(bIockp); 

IF ADDRESS(blockp) <> NIL THEN 

FOR i :« 0 TO bIockSize(bIockp)-1 DO 
WriteCord(i, 3); WriteString(*; ’); 

WriteCord(CARDINAL(getWord(bIockp, i)), 0); WriteLn; 

END; 

END; 

END printBlock; 


PROCEDURE rowPrintFreeList; 

VAR bpibPtr; 

BEGIN 

bp :■ bPtr(getFreeList()); 

WHILE bp <> NIL DO 

rawPrIn t BIockHeoder(bp); 
bp := bp^.nextBlock; 

END; 

Wr i teLnStr ing("-") ; 

END rowPrintFreeList; 

PROCEDURE printFreeL i st; 

VAR bp:bIockPtr; 

bptr:bPtr; 

BEGIN 

bp :■ getFreeList(); 

WHILE ADDRESS(bp) <> NIL DO 
printBIockHeoder(bp); 
bptr bPtr(bp); 
bp := blockPtr(bptr^.nextBlock); 

END; 

Wr i teLnStr ing("-••) . 

END printFreeList; 


PROCEDURE test; 
VAR cl. c2:CHAR; 
BEGIN 
LOOP 


Wr i te(*>*); 

Read(cl); Wrlte(cl); 
Read(c2); Write(c2); 
CASE cl OF 


’a *: doAI Ioc(c2); 

*f': doFree(c2); 

# r*: IF Iet ter(c2) THEN 

r awPrintBIock(bPtr(bIockList[c21)); 
ELSE 

rowPrintFreeList; 

END; 

’P*: IF Iet ter(c2) THEN 

pri ntB I ock (bI ockL ist [c2l) ; 

ELSE 


printFreeList; 

END; 

’s’: doSet(c2); 

’g’: doGet(c2); 

’q»: EXIT; 

ELSE 

WriteLnString("a)I Ioc f f)ree, p)rint, r)aw print, 
END; 

END; 

END test; 


qu) i t, 


s) 


PROCEDURE doAI Ioc(b:CHAR); 

BEGIN 

bIockList[b] := a I Iocate(getCard("Number of words: "))• 
END doAlloc; 


t, g)et") 
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PROCEDURE doFree(b:CHAR); 

BEGIN 

free(bIockList[b]); 

END doFree; 

PROCEDURE doSet(b:CHAR); 

BEGIN 

setWord(bIockList[b], getCard("Position: "), getCard("VaIue: ")); 

END doSet; 

PROCEDURE doGet(b:CHAR); 

BEGIN 

WriteCard(CARDINAL(getWord(bIockList[b], getCard("Position: "))), 0); 
END doGet; 

PROCEDURE getCard(s:ARRAY OF CHAR):CARDINAL; 

VAR c:CARDINAL; 

BEGIN 

Wr i teString(s); 

ReadCard(c); 

WriteLn; 

RETURN c; 

END getCard; 

PROCEDURE Ie 11 e r(c:CHAR):BOOLEAN; 

BEGIN 

RETURN (c >= * a *) AND (c <* 'z'); 

END letter; 

PROCEDURE init; 

VAR c:CHAR; 

BEGIN 

FOR c :« * a * TO ‘z* DO 

bIockList[c] :« bIockPtr(NIL); 

END; 

END init; 

BEGIN 

CI earScreen; 
init; 
test; 

END olloci test. 


A2TEST.MOD 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


MODULE a Iloc2test; 

FROM Alloc2 IMPORT blockPtr, allocate, free, setWord, getWord, blockSize, 
getFreeList; 

FROM MyTerminal IMPORT WriteString, Write, WriteLnString, WriteLn, 

WriteCard, fatal, pause, ClearScreen, Read; 

FROM SYSTEM IMPORT WORD, ADDRESS; 

FROM InOut IMPORT ReadCard; 

FROM MachineSpecific IMPORT writeAddress; 

CONST maxlndex - 32767; 

TYPE bPtr - POINTER TO block; 
block - RECORD 

size:CARDINAL; 

CASE BOOLEAN OF 

TRUE: nextBlock: bPtr; 

| FALSE: contents:ARRAY[0..maxlndex] OF WORD; 

END; 

END; 

VAR bIockList:ARRAY[* a * . . ’ z ’ ] OF blockPtr; 

PROCEDURE rawPrintBIockHeader(bIockp:bPtr); 

( continued ) 
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Wr 1 teLnSt r i ng("- ) • 

IF ADDRESS(blockp) - NIL THEN 
WriteLnString("NIL"); 

LLSE WrIteStrlng("Block (row) "); 

writeAddress(ADDRESS(blockp)); 

WrIteStrlng(" ("); 

WriteCord(blockp".si ze, 0); 

WrIteLnStrIng(" words)"): 

ENO; 

ENC rowPrintBlockHeoder; 

PROCEDURE rowPrIntBlock(bIockp:bPtr); 

VAR i:CARDINAL; 

BEGIN 

rowPr1ntBIockHeoder(bIockp); 

IF blockp <> NIL THEN 
WITH blockp" DO 

FOR I 0 TO size-1 DO 

WriteCord(i, 3); WriteStrino(’: ’): 

WriteCord(CARDINAL(contents[i]), 0); WrlteLn; 

END; 

END; 

END; 

END rowPrintBlock; 

PROCEDURE printBIockHeoder(blockp:bIockPtr); 

BEGIN , llN 

Wr i teLnStr ing(“- )• 

IF ADDRESS(blockp) « NIL THEN 
Wri teLnString("NIL"): 

ELSE 

WriteStrlng("Block “); 

writeAddress(ADDRESS(bIockp)); 

Wr i teString(" ("); 

WriteCord(bIockSize(bIockp), 0); 

WriteLnString(" words)"); 

END: 

END printBlockHeoder; 

PROCEDURE printBIock(bIockp;blockPtr); 

VAR i;CARDINAL; 

BEGIN 

printBlockHeoder(blockp); 

IF ADDRESS(blockp) <> NIL THEN 

FOR i := 0 TO bIockSize(bIockp)-1 DO 

WriteCord(i, 3); WriteString(’: '): . 

Writ eCord (CARDINAL(getWord(bIockp. i)), 0); WriteLn 

END; 

END; 

END printBlock; 


PROCEDURE rawPrintFreeList; 
VAR bpibPtr; 


BEGIN 

bp :* bPtr(getFreeList()); 
WHILE bp <> NIL DO 

rawPrintBIockHeader(bp); 


bp :• bp A .nextBIock; 

END; 

Wr i teLnString("- 

END rawPrintFreeList; 




PROCEDURE printFreeList; 

VAR bp:bIockPtr; 

bptr:bPtr; 

BEGIN 

bp :* getFreeList() ; 

WHILE ADDRESS(bp) <> NIL DO 
printBlockHeoder(bp); 
bptr := bPtr(bp); 
bp ;« blockPtr(bptr*.nextBlock) 
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END; 

Wr iteLnStr ing("-"); 

END prIntFreeL i st; 

PROCEDURE test; 

VAR cl. c2;CHAR; 

BEGIN 

LOOP 

Write(*>*); 

Read(cl); Write(cl); 

Read(c2); Write(c2); 

CASE cl OF 

'a* : doAIloc(c2); 

*f*: doFree(c2); 

•r *: IF Ietter(c2) THEN 

rawPrintBIock(bPtr(bIockList[c2])); 

ELSE 

rawPrIntFreeL1st; 

END; 

| *p•: IF Ietter(c2) THEN 

printBIock(bIockL1st[c2]); 

ELSE 

printFreeL1st; 

END; 

’s’: doSet(c2); 

'g': doGet(c2); 

*c’: doCopy(c2); 

‘q’: EXIT; 

ELSE 

WrIteLnString("a)Iloc, f)ree, p)rint, r)aw print, qu)it, s)et, g)et,"); 
WrIteLnString("c)opy"); 

END; 

END; 

END test; 

PROCEDURE doCopy(source:CHAR); 

VAR des t:CHAR; 

BEGIN 

WriteString("Copy to; "); 

Read(dest); 

bIockList[dest] :» bIockLIst[source]; 

END doCopy; 

PROCEDURE doAlloc(b:CHAR); 

BEGIN 

blockList[b] := aMocate(getCard("Number of words: ")); 

END doAIloc; 

PROCEDURE doFree(b:CHAR); 

BEGIN 

free(blockList[b]) ; 

END doFree; 

PROCEDURE doSet(b:CHAR); 

BEGIN 

setWord(bIockLIst[b], getCard("Posi11 on; "), getCard("VaIue: ")); 

END doSet; 

PROCEDURE doGet(b:CHAR); 

BEGIN 

WriteCord(CARDINAL(getWord(bIockList[b], getCard("Position: "))), 0); 

END doGet; 

PROCEDURE getCard(s:ARRAY OF CHAR):CARDINAL; 

VAR c;CARDINAL; 

BEGIN 

WriteStrina(s); 

ReadCard(c); 

Wr I teLn; 

RETURN c; 

END getCard; 

PROCEDURE Ie 11 e r(c:CHAR):BOOLEAN; 

BEGIN 


(continued) 
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RETURN (c >- ’a') AND (c <« * 2 *); 
ENO letter; 

PROCEDURE inlt; 

VAR c:CHAR; 

BEGIN 

FOR c :« ’a* TO ’z‘ DO 

bIockList[c] blockPtr(NIL); 

END; 

END Inlt; 

BEGIN 

CI earScreen; 

Inlt; 
test; 

END alIoc2test. 


A3TEST.MOD 

Programming Project; "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


MODULE a I Ioc3test; 

FROM Alloc3 IMPORT handle, allocate, free, setWord, getWord, blockSize, 
getFreeList, resize, wrlteMap; 

FROM MyTerminal IMPORT WrlteStrlng, Write, WriteLnStrIng, WriteLn, 
WriteCard, fatal, pause, ClearScreen, Read; 

FROM SYSTEM IMPORT WORD. ADDRESS; 

FROM InOut IMPORT ReadCard; 

FROM MachineSpecific IMPORT wrIteAddress; 

CONST maxlndex - 32767; 

TYPE hndI - POINTER TO bPtr; 
bPtr - POINTER TO block; 
block - RECORD 

size:CARDINAL; 

CASE BOOLEAN OF 

TRUE; nextBlock; bPtr; 

| FALSE; contents:ARRAY[0..maxlndex] OF WORD; 

END; 

END; 

VAR bIockList;ARRAY[* a *..' z ' ] OF handle; 

PROCEDURE rawPrintBIockHeader(bIockp;bPtr); 

BEGIN 

Wr iteLnStr lng("-"); 

IF ADDRESS(blockp) = NIL THEN 
Wr iteLnString("NIL"); 

ELSE 

WriteString("Block (raw) "); 
writeAddress(ADDRESS(bIockp)); 

Wr iteString(" ("); 

WriteCard(bIockp*.size, 0); 

WriteLnString(" words)"); 

END; 

END rawPrintBIockHeader; 

PROCEDURE rawPrintBIock(bIockp:bPtr); 

VAR i;CARDINAL; 

BEGIN 

rawPrintBIockHeader(bIockp); 

IF bIockp <> NIL THEN 
WITH blockp~ DO 

FOR i ;= 0 TO size-1 DO 

WriteCard(i, 3); WriteString(*; ’); 
WriteCard(CARDINAL(contents[i]), 0); WriteLn; 
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END; 

END; 

END; 

END rawPrintBIock; 

PROCEDURE printBIockHeader(bIockh:handIe); 

VAR a;hndI; 

BEGIN 

a :* hndI(bIockh); 

Wr iteLnStr ing("-"); 

IF a* « bPtr(NIL) THEN 
Wr iteLnString("NIL"); 

ELSE 

Wr iteString("Block "); 

writeAddress(ADDRESS(bIockh)); 

WriteString(" ("); 

WriteCard(bIock$ize(bIockh), 0); 

Wr i teLnString(" words)"); 

END; 

END printBIockHeader; 

PROCEDURE printBIock(bIockh:hand Ie); 

VAR i:CARDINAL; 

BEGIN 

printBIockHeader(bIockh); 

IF ADDRESS(blockh) <> NIL THEN 

FOR i := 0 TO bIockSize(bIockh)-1 DO 
Wr i teCard(i, 3); WriteString(*: ’); 

WriteCard(CARDINAL(getWord(bIockh, i)), 0); WriteLn; 

END; 

END; 

END printBIock; 

PROCEDURE rawPrIntFreeList; 

VAR bp:bPt r; 

BEGIN 

bp :■ bPtr(getFreeList()); 

WHILE bp <> NIL DO 

rawPrintBIockHeader(bp) ; 
bp := bp*.nextBIock; 

END; 

Wr IteLnStr ing("-"); 

END rawPrintFreeList; 

(* 

PROCEDURE printFreeL 1st; 

VAR bpiblockPtr; 

bptr:bPtr; 

BEGIN 

bp :■ getFreeList(); 

WHILE ADDRESS(bp) <> NIL DO 
pr intBIockHeader(bp); 
bptr :« bPtr(bp); 
bp := blockPtr(bptr*.nextBlock); 

END; 

Wr iteLnStr ing("-"); 

END printFreeL1st; 

*) 

PROCEDURE test; 

VAR cl, c2:CHAR; 

BEGIN 

LOOP 

Wr I te(*>•); 

Read(cl); Write(cl); 

Read(c2); Write(c2); 

CASE cl OF 

’a’; doAlloc(c2); 

•f•: doFree(c2); 
j * r *; IF Ietter(c2) THEN 

doRawPrIn t BIock(c2); 

ELSE 

rawPrintFreeList; 

END; 


[continued ) 
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I v 


ELSE 


* s' 

* 9 * 
*c* 
» w » 

* e * 

V 


IF Ietter(c2) THEN 

ELs£ rlntB,ock ( b,ockLi st[ c2 ]); 

(*prIntFreeList*); 

END; 

doSet(c2); 
doGet(c2); 
doCopy(c2); 
wrIteMap; 
doResize(c2); 

EXIT; 


Wrlt!| L «f* r i n9 fl a } 1 l0C ’ P ree> p) rir >t. r)ow print. qu)it, s)et g)et ") 
END* eLnStr 09 C ^° Py '* w ) r ' te ma P» r(e)size"); ' ’ ^ * ' 

END; 

END test; 


PROCEDURE doRawPrintBIock(c:CHAR)• 

VAR bIockh:hndI; 

BEGIN 

bIockh hndl(blockL1st[cl); 
rawPrIntBlock(blockh^); 

END doRawPrIntBIock; 

PROCEDURE doCopy(source:CHAR); 

VAR dest:CHAR; 

BEGIN 

WriteString("Copy to: "); 

Read(dest); 

b I ockL i s t [ des t] : = blockList[source!; 

END doCopy; J 

PROCEDURE doAlloc(b:CHAR); 

BEGIN 

END doAl^oc^^ al locate(getCard( M Number of words: ")): 


PROCEDURE doFree(b:CHAR); 
BEGIN 

f ree(bIockL f st[bl); 
END doFree; 


PROCEDURE doSet(b:CHAR); 
BEGIN 

setWord(blockList[bl, 

END doSet; 


getCard("Position: "), getCard("VaIue 


”)): 


PROCEDURE doGet(b:CHAR); 

BEGIN 

rKin WriteCard(CARDINAL(getWord(blockList[bl, 

END L J 


getCard(“Position: 


))). 0 ): 


PROCEDURE doResize(c:CHAR); 

BEGIN 

resi2e (blocklist[c] ( getCard("New Size: "))• 
END doRes ize; 

PROCEDURE getCard(s:ARRAY OF CHAR):CARDINAL• 

VAR c:CARDINAL; 

BEGIN 

WriteString(s) ; 

ReadCard(c); 

WriteLn; 

RETURN c; 

END getCard; 


PROCEDURE Ie11 e r(c:CHAR):BOOLEAN• 
BEGIN 

RETURN (c >= ’a’) AND (c <= ’z’) 
END letter; J 
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PROCEDURE init; 

VAR c:CHAR; 

BEGIN 

FOR c := ’a’ TO ’z’ DO 

blockList[c] :* handle(NIL); 

END; 

END init; 

BEGIN 

CIearScreen; 
init; 
test; 

END a I Ioc3test. 


A4TEST.MOD 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


MODULE alloc4test; 

FROM Alloc4 IMPORT capability, allocate, free, setWord, getWord, blockSize, 
getFreeList, resize, writeMap; 

FROM MyTerminal IMPORT WriteString, Write, WriteLnString, WriteLn, 
WriteCard, fatal, pause, ClearScreen, Read; 

FROM SYSTEM IMPORT WORD, ADDRESS; 

FROM InOut IMPORT ReadCard; 

FROM MachineSpecific IMPORT writeAddress; 

CONST maxlndex = 32767; 

VAR bIockList:ARRAY[' a'.. * z * ] OF capability; 


PROCEDURE printBIockHeader(bIockc:capabiIity); 

BEGIN 

Wr i teLnSt r i ng("-"); 

WriteString("Block "); 

writeAddress(ADDRESS(bIockc)); 

WriteString(" ("); 

WriteCard(bIockSize(blockc), 0); 

WriteLnString(" words)"); 

END printBIockHeader; 

PROCEDURE printBIock(bIockc:capabiIity); 

VAR i:CARDINAL; 

BEGIN 

printBIockHeader(bIockc); 

FOR i :* 0 TO bIockSize(bIockc)-1 DO 
WrlteCard(i, 3); WriteString(*: ’); 

WriteCard(CARDINAL(getWord(bIockc, i)), 0); WriteLn; 

END; 

END printBIock ; 


(* 

PROCEDURE printFreeList; 

VAR bp:bIockPt r; 

bpt r:bPt r; 

BEGIN 

bp :« getFreeList(); 

WHILE ADDRESS(bp) <> NIL DO 
printBIockHeader(bp); 
bptr :■ bPtr(bp); 
bp :* bIockPtr(bptr*.nextBIock); 

END; 

WriteLnStr ing("-"); 

END printFreeL i st; 

*) 


(continued) 
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PROCEDURE test; 

VAR cl, c2:CHAR; 

BEGIN 

LOOP 

Wr I te(’>’); 

Reod(cl); Write(cl); 

Read(c2); Write(c2); 

CASE cl OF 

: doAlloc(c2); 

*1*: doFree(c2); 

: IF Ietter(c2) THEN 

printBIock(bIockList[c2]); 

ELSE 

(*printFreeList*); 

END; 

’s’; doSet(c2); 

'g': doGet(c2); 

’c’: doCopy(c2); 

*w’: wrIteMap; 

’e‘: doResIze(c2); 

’ q *: EXIT; 

ELSE 

WriteLnString("a^I I oc, f)ree, p)rint, qu)it, s)ct, g)et, M ); 
WriteLnString("c)opy, w)rlte map, r(e)size"); 

END; 

END; 

END test; 

PROCEDURE doCopy(source:CHAR); 

VAR dest:CHAR; 

BEGIN 

WriteString("Copy to; "); 

Read(dest); 

b I ockLIst[dest] := bIockList[source]; 

END doCopy; 

PROCEDURE doAI Ioc(b:CHAR); 

BEGIN 

bIockList[b] a Ilocate(getCard("Number of words; ")); 

END doAlloc; 

PROCEDURE doFree(b:CHAR); 

BEGIN 

f ree(bIockList[b]); 

END doFree; 

PROCEDURE doSet(b:CHAR); 

BEGIN 

setWord(blockList[b], getCard("Position; getCard("VaIue; ")) 

END doSet; 

PROCEDURE doGet(b:CHAR); 

BEGIN 

WriteCard(CARDINAL(getWord(bIockL1st[b], getCard("Position: "))) 
END doGet; 

PROCEDURE doResize(c:CHAR); 

BEGIN 

res Ize(bIockList[c], getCard("New Size: ")); 

END doResize; 

PROCEDURE getCard(s:ARRAY OF CHAR);CARDINAL; 

VAR c;CARDINAL; 

BEGIN 

WriteString(s); 

ReadCard(c); 

Wr iteLn; 

RETURN c; 

END getCard; 

PROCEDURE Ie11 e r(c;CHAR):BOOLEAN; 

BEGIN 

RETURN (c >= ’a’) AND (c <= ’z’); 

END letter; 
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PROCEDURE init; 

VAR c:CHAR; 

BEGIN 

FOR c := 1 a ' TO 'z’ DO 

bIockList[c] :« capabiIity(NIL); 

END; 

END init; 

BEGIN 

ClearScreen; 
init; 
test; 

END a I Ioc4test. 


ALLOC.DOC 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


Notes on the Storage Allocators 

Four storage allocators are included, as described in the article. The four 
driver programs, altest, a2test, etc., can be used to test the allocators. The 
driver programs are very similar. Each provides twenty-six one-letter 

variables, which hold references to blocks. The following commands are 
avaitable: 


a<letter> 

f<letter> 
g<letter> 


Allocates a block and store in variable <letter>. Prompts for 
size of block. 

Frees block. 

Gets a word from block. Prompts for index. Prints word as a 
CARDINAL. 


s<letter> Sets a word in block. Prompts for index and value of word. 

p<letter> Prints contents of block. 

p<char> If anything but a letter follows p, the free list is displayed. 

Some drivers also provide an "r" command which prints the block in "raw" 
mode, by looking directly at its contents, rather than going through the setWord 
and getWord procedures as "p" does. 


a3test and a4test provide a "w" command which displays a map of the heap: the 
allocated and free areas, their locations and sizes. These two drivers also 
provide an "e" command for rEsizing a block. 

The module MachineSpecific contains information which might vary from computer 
to computer. Make sure you change this module before compiling the allocators 
on your machine. The way capabilities are encoded in Alloc4 will not work 

on 16-bit machines. You will have to rewrite the module to make it work. 


I am always interested in hearing comments, bug reports, etc. You can reach me 
on BIX as jba or write me at 


Jonathan Amsterdam 
1643 Cambridge St. #34 
Cambridge, MA 02138 


ALL0C1.DEF 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


DEFINITION MODULE AI loci; 

(* A simple storage allocator using the first-fit method. 

(continued) 
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Copyright 1986 by Jonathon Amsterdam. All Rights Reserved. *) 

FROM SYSTEM IMPORT WORD; 

EXPORT QUALIFIED blockPtr. blockSIze, getWord. setWord, allocate, free 
getFreeList; * 


TYPE blockPtr; (* pointer to a block*) 

PROCEDURE b I ockSIze(bIockp ; bIockPt r) :CARDINAL; 
(* Size of block *) 


PROCEDURE getWord(bIockp:blockPtr; n:CARDINAL):WORD; 

(* Returns n’th word of block. Block indexed from 0 to blockSlze-1* 
dies If n > blockSlze-1. *) * 


PROCEDURE setWord(bIockp:bIockPtr; n:CARDINAL; w:WORD)- 
(* sets n'th word of block to w; dies if n > blockSize-1. *) 


PROCEDURE allocote(nWords:CARDINAL):blockPtr; 

(* allocates a block of nWords words (possibly slightly more 


in some cases) 


PROCEDURE free(VAR freeBIock:bIockPtr); 

(* frees block pointed to by freeBlock if 
freeBlock to NIL. *) 


it points into the heap, and sets 


*) 


PROCEDURE getFreeList():blockPtr; 

(* Returns a pointer to the free list, 
be removed in "production" versions 

END Alloci. 


For debugging only. This should 
of the a I Iocator. *) 


ALLOC1.MOD 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


IMPLEMENTATION MODULE Allocl; 

(* A simple storage allocator that uses the first-fit strategy. 

Copyright 1986 by Jonathan Amsterdam. All Rights Reserved. *) 

FROM SYSTEM IMPORT WORD, ADDRESS, TSIZE; 

FROM MachineSpecific IMPORT getHeapBottom, getHeapTop, bytesPerWord, 
address, cardinal, addrLessThan, writeAddress; 

FROM MyTerminal IMPORT fatal; 

CONST maxlndex = 32767; 

TYPE blockPtr * POINTER TO block; 
block = RECORD 

size:CARDINAL; (★ not including header *) 

CASE BOOLEAN OF 

TRUE: nextBlock: blockPtr; 

| FALSE: contents:ARRAY[0..maxlndex] OF WORD; 

END; 

END; 

VAR heapBottom, heapTop:ADDRESS; 
freeList:blockPtr; 

bIockHeaderSize, minBIockSize:CARDINAL; 

PROCEDURE init; 

VAR a:ADDRESS; 

BEGIN 

heapBottom getHeapBottom(); 
heapTop := getHeapTop(); 
freeList := bIockPtr(heapBottom); 
freeList~.size :« 

(cardinal(heapTop - heapBottom) DIV bytesPerWord) - bIockHeaderSize; 
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freeList*.nextBlock :* NIL; 

bIockHeaderSize := TSIZE(CARDINAL); 

minBIockSize := TSIZE(bIockPtr) + bIockHeaderSize; 

END init; 

PROCEDURE bIockSize(bIockp:bIockPtr);CARDINAL; 

BEGIN 

RETURN bIockp*.size; 

END blockSize; 

PROCEDURE getWord(bIockp:bIockPtr; n:CARDINAL):WORD; 

BEGIN 

IF n < blockp*.size THEN 

RETURN blockp*.contents[n]; 

ELSE 

fataI(’getWord: out of bounds’); 

END; 

END getWord; 

PROCEDURE setWord(bIockp:bIockPtr; n:CARDINAL; w:WORD); 

BEGIN 

IF n < blockp*.size THEN 

blockp*.contents[n] := w; 

ELSE 

fataI(*setWord; out of bounds’); 

END; 

END setWord; 

PROCEDURE alIocate(nWords:CARDINAL):bIockPtr; 

VAR currBlock, prevBIock:bIockPtr; 

BEGIN 

currBlock :« freeList; 
prevBlock := NIL; 

WHILE currBlock <> NIL DO 

IF nWords + minBlockSize < currBIock*.size THEN 

(* split the block into two, returning the 2nd part *) 

DEC(currBIock*.size, nWords+bIockHeaderSize); 

INC(currBIock, bytesPerWord*(bIockHeaderSize + currBlock*.s ize)); 
currBlock*.size :« nWords; 

RETURN currBlock; 

ELSIF nWords <* currBlock*.size THEN (* return the whole block *) 

Iink(prevBIock, currBlock*.nextBlock); 

RETURN currBlock; 

END; 

prevBlock :« currBlock; 
currBlock :« currBlock*.nextBlock; 

END; 

RETURN NIL; 

END a I Iocate; 

PROCEDURE free(VAR freeBIock:bIockPtr); 

VAR currBlock, prevBIock;bIockPtr; 

BEGIN 

IF addrBetween(heapBottom, freeBlock, heapTop) THEN 
currBlock :« freeList; 
prevBlock NIL; 

WHILE (currBlock <> NIL) AND addrLessThan(currBIock, freeBlock) DO 
prevBlock :* currBlock; 
currBlock :* currBlock*.nextBlock; 

END; 

IF currBlock * NIL THEN 

freeBlock*.nextBlock :• NIL; 

Iink(prevBIock, freeBlock); 

ELSE (★ freeBlock belongs just before currBlock *) 
freeBlock*.nextBlock :« currBlock; 

Iink(prevBlock, freeBlock); 

END; 

tryToMerge(prevBIock, freeBlock, currBlock); 
freeBlock NIL; 

END; 

END free; 

PROCEDURE tryToMerge(lowBlock, middleBlock, highBIock;bIockPtr); 

BEGIN 

IF adjacent(middIeBIock, highBlock) THEN 


{continued) 
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merge(middIeBlock, highBlock); 

END; 

IF adjacent(IowBIock, middleBlock) THEN 
merge(IowBIock, middleBlock); 

END; 

END tryToMerge; 

PROCEDURE adjacent(lowerBlock, higherBIock:bIockPtr):BOOLEAN; 

BEGIN 

RETURN 

(lowerBlock <> NIL) AND 
(higherBIock <> NIL) AND 

(lowerBlock + address(bytesPerWord*(IowerBI ock".size + bIockHeaderSize)) * 
higherBlock); 

END adjacent; 

PROCEDURE merge(IowerBIock, higherBIock:bIockPtr); 

BEGIN 

INC(lowerBlock".size, higherBIock".size + bIockHeaderSize); 
lowerBlock".nextBlock := higherBIock".nextBIock; 

END merge; 

PROCEDURE Iink(prevBIock, I 1nkBIock:bIockPtr); 

BEGIN 

IF prevBlock = NIL THEN 
freeList := linkBlock; 

ELSE 

prevBlock".nextBlock :« linkBlock; 

END; 

END link; 

PROCEDURE addrBetween(low, middle, high:ADDRESS):BOOLEAN; 

BEGIN 

RETURN (addrLessThan(low, middle) OR (low - middle)) AND 
(addrLessThan(middIe, high) OR (middle ■ high)); 

END addrBetween; 

PROCEDURE getFreeList():bIockPtr; 

(* for debugging only *) 

BEGIN 

RETURN freeList; 

END getFreeList; 

BEGIN 

init; 

END AI loci. 


ALL0C2.DEF 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


DEFINITION MODULE Alloc2; 

(* A safe storage allocator using the first-fit method. 

Copyright 1986 by Jonathan Amsterdam. All Rights Reserved. *) 

FROM SYSTEM IMPORT WORD; 

EXPORT QUALIFIED blockPtr, blockSize, getWord, setWord, allocate, free, 
getFreeList; 

TYPE blockPtr; (* pointer to a block*) 

PROCEDURE bIockSize(bIockp:bIockPtr):CARDINAL; 

(* Size of bIock *) 

PROCEDURE getWord(blockprbIockPtr; n:CARDINAL):WORD; 

(* Returns n’th word of block. Block indexed from 0 to blockSize-1; 
dies if n > blockSize-1. *) 

PROCEDURE setWord(bIockp:bIockPtr; n:CARDINAL; w:WORD); 

(* sets n’th word of block to w; dies if n > blockSize-1. *) 
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PROCEDURE cI Iocate(nWords:CARDINAL):blockPtr; 

(* allocates a block of nWords words (possibly slightly more, in some cases) *) 
PROCEDURE free(VAR freeBIock:bIockPtr); 

(* frees block pointed to by freeBlock if it points into the heap, and sets 
freeBlock to NIL. *) 

PROCEDURE getFreeList():blockPtr; 

(* Returns a pointer to the free list. For debugging only. This should 
be removed in "production" versions of the allocator. *) 

END AI Ioc2. 


ALL0C2.MOD 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


IMPLEMENTATION MODULE Alloc2; 

(* A storage allocator that tries to be safe about freed blocks. 

It detects attempts to access freed blocks by leaving "tombstones" 
in the heap. 

Copyright 1986 by Jonathan Amsterdam. All Rights Reserved. *) 

FROM SYSTEM IMPORT WORD, ADDRESS, TSIZE; 

FROM MachineSpecific IMPORT getHeapBottom, getHeapTop, bytesPerWord, 
address, cardinal, addrLessThan, writeAddress; 

FROM MyTerminal IMPORT fatal; 

CONST maxlndex = 32767; 

TYPE bIockPtr * POINTER TO block; 
block = RECORD 

size:CARDINAL; (* not including header *) 

CASE BOOLEAN OF 

TRUE: nextBlock: blockPtr; 

| FALSE: contents:ARRAY[0..moxlndexl OF WORD; 

END; 

END; 

VAR heapBottom, heapTop:ADDRESS; 
freeList:bIockPt r; 

bIockHeaderSize, minBIockSize:CARDINAL; 

PROCEDURE init; 

BEGIN 

heapBottom :« getHeapBottom(); 

heapTop :« getHeapTop(); 

bIockHeaderSize :* TSIZE(CARDINAL); 

minBlockSize := TSIZE(blockPtr) + bIockHeaderSize; 

freeList :■ bIockPtr(heapBottom); 

freeList*.size :* 

(cardinal(heapTop-heapBottom) DIV bytesPerWord) - blockHeaderSize + 1; 
freeList^.nextBlock := NIL; 

END init; 

PROCEDURE bIockSize(bIockp:bIockPtr):CARDINAL; 

BEGIN 

RETURN blockp^.size; 

END bIockSize; 

PROCEDURE getWord(blockp:blockPtr; n:CARDINAL):WORD; 

BEGIN 

tombstoneCheck(bIockp); 

IF n < blockp^.size THEN 

RETURN blockp*.contents[n]; 

ELSE 

fataI(*getWord: out of bounds’); 

END; 

END getWord; 


(continued) 
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PROCEDURE setWord(blockp:bIockPtr; n:CARDINAL; w:WORD): 

BEGIN ' 

tombstoneCheck(blockp); 

IF n < blockp".slze THEN 

blockp".contents[nl :« w; 

ELSE 

fotaI(*setWord: out of bounds'): 

END; 

END setWord; 

PROCEDURE alIocate(nWords:CARDINAL):bIockPtr; 

VAR currBlock, prevBIock:bIockPtr; 

BEGIN 

currBlock :« freeList; 
prevBlock :* NIL; 

WHILE currBlock <> NIL DO 

IF nWords + minBlockSize < currBIock".size THEN 

(* split the block into two, returning the 2nd part *) 

DECfcur rBIock".size, nWords+bIockHeaderSize); 

INC(currBIock, bytesPerWord*(bIockHeaderSize + currBIock".size 
currBIock".size :« nWords; 

RETURN currBlock; 

ELSIF nWords <= currBIock".size THEN (* return the whole block *) 

Iink(prevBIock, currBlock".nextBlock); 

RETURN currBlock; 

END; 

prevBlock := currBlock; 
currBlock := currBlock".nextBlock; 

END; 

RETURN NIL; 

END a I Iocate; 

PROCEDURE free(VAR freeBIock:bIockPtr); 

VAR currBlock, prevBlock, temp:bIockPtr; 

BEGIN 

IF NOT addrBetween(heapBottom, freeBlock, heapTop) THEN 
fatal("free: block not in heap"); 

ELSIF freeBlock".size ■ 0 THEN 

fatal("free: attempt to free an already freed block"); 

ELSIF freeBlock".size - bIockHeaderSize < minBlockSize THEN 

(* don’t attempt to incorporate the block into the freelist *) 
freeBlock".size :» 0; ' 

freeBlock NIL; 

ELSE 

temp :« freeBlock; 

INC(freeBIock, bytesPerWord*bIockHeaderSize); 
freeBlock".size := temp".size - bIockHeaderSize; 
temp".size := 0; 
currBlock := freeList; 
prevBlock :* NIL; 

WHILE (currBlock <> NIL) AND addrLessThan(currBIock, freeBlock) DO 
prevBlock := currBlock; 
currBlock currBIock".nextBIock; 

END; 

IF currBlock = NIL THEN 

freeBlock".nextBlock := NIL; 

Iink(prevBIock, freeBlock); 

ELSE (* freeBlock belongs just before currBlock *) 
freeBlock".nextBlock :« currBlock; 

Iink(prevBIock, freeBlock); 

END; 

tryToMerge(prevBIock, freeBlock, currBlock)- 
freeBlock := NIL; 

END; 

END free; 


PROCEDURE tryToMerge(IowBlock, 
BEGIN 


m i ddIeBIock, 


hi ghB I ock:bIockPt r ) ; 


IF adjacent(middIeBIock, highBlock) THEN 
merge(middIeBIock, highBlock); 

END; ' 

IF adjacent(IowBIock, middleBlock) THEN (* this should be 
merge(IowBIock, middleBlock); 

END; 

END tryToMerge; 


impossibIe 


*) 
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PROCEDURE adjacent(lowerBlock, higherBIock:bIockPtr):BOOLEAN; 

BEGIN 

RETURN 

(lowerBlock <> NIL) AND 
(higherBlock <> NIL) AND 

(lowerBlock + address(bytesPerWord*(lowerBlock".size + bIockHeaderSize)) 
higherBlock); J/ 

END adjacent; 

PROCEDURE merge(lowerBlock, higherBIock:bIockPtr)• 

BEGIN 

INC(lowerBlock".size, higherBIock".sIze + bIockHeaderSize)• 
lowerBlock".nextBlock := higherBlock".nextBlock; 

END merge; 


PROCEDURE Iink(prevBlock, IinkBIock:bIockPtr); 
BEGIN 

IF prevBlock = NIL THEN 
freeList := linkBlock; 

ELSE 


prevBlock^.nextBlock := linkBlock; 

END; 

END link; 


PROCEDURE addr8etween(low, middle, high:ADDRESS):BOOLEAN; 
BEGIN 

RETURN (addrLessThan(low, middle) OR (low = middle)) AND 
(addrLessThan(middIe, high) OR (middle = high)); 
END addrBetween; 

PROCEDURE tombstoneCheck(bIockp;bIockPt r); 

BEGIN 

IF blockp".size ■ 0 THEN 

fatal("attempt to access a freed block"): 

END; ' 

END tombstoneCheck; 

PROCEDURE getFreeList();blockPtr; 

(* for debugging only *) 

BEGIN 

RETURN freeList; 

END getFreeList; 

BEGIN 

Init; 

END AI Ioc2. 


ALL0C3.DEF 

Programming Project; "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


DEFINITION MODULE Alloc3; 

(* A safe storage allocator using the first-fit method and handles. 

Copyright 1986 by Jonathan Amsterdam. All Rights Reserved. *) 

FROM SYSTEM IMPORT WORD; 

EXPORT QUALIFIED handle, blockSize, getWord, setWord, allocate, free 
getFreeList, resize, writeMap; 

TYPE handle; (* pointer to a pointer to a block*) 

PROCEDURE bIockSize(h:hand Ie):CARDINAL; 

(* Size of block *) 

PROCEDURE getWord(h:hand Ie; n:CARDINAL):WORD; 

(* Returns n’th word of block. Block indexed from 0 to blockSize-1- 
dies If n > blockSize-1. *) 

PROCEDURE setWord(h:hand Ie; n:CARDINAL; w:WORD); 

(* sets n * th word of block to w; dies if n > blockSize-1. *) 

( continued) 
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PROCEDURE a Ilocate(nWords:CARDINAL):handIe; 

(* allocates a block of nWords words (possibly slightly more, in some cases) *) 

PROCEDURE f ree(VAR freeBIock:hand Ie); 

(* frees block pointed to by freeBlock if it points Into the heap, and sets 
freeBlock to NIL. *) 

PROCEDURE res Ize(h:hand Ie; nWordsrCARDINAL); 

(* attempts to change size of block referenced by h *) 

PROCEDURE writeMap; 

(* Writes, in order of address, the free and allocated blocks and their 
sizes. For debugging only; should be removed in "production" versions 
of the a I locator. *) 

PROCEDURE getFreeList():handle; (* really a blockPtr *) 

(* Returns a pointer to the free list. For debugging only. This should 
be removed In "production" versions of the allocator. *) 

END AIloc3. 


ALL0C3.M0D 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


IMPLEMENTATION MODULE Alloc3; 

(* A storage allocator that tries to be safe about freed blocks. 

It uses "handles" (pointers to pointers) to keep track of blocks. 

It also compacts space, and allows resizing. 

Copyright 1986 by Jonathan Amsterdam. All Rights Reserved. *) 

FROM SYSTEM IMPORT WORD, ADDRESS, TSIZE, ADR; 

FROM MachineSpecifIc IMPORT getHeapBottom, getHeapTop, bytesPerWord, 

address, cardinal, addrLessThan, wr1teAddress, addWords, subtractWords, 
maxAddress; 

FROM MyTerminaI IMPORT fatal, WrIteLnString, WriteCard, 

WriteString, WriteLn; 

CONST maxlndex =* 32767; 

nMasters = 10; (* number of masters to allocate each time more needed *) 

TYPE handle = POINTER TO blockPtr; 
blockPtr = POINTER TO block; 
block = RECORD 

size:CARDINAL; (* not including header *) 

CASE BOOLEAN OF 

TRUE: nextBlock: blockPtr; 

| FALSE: contents:ARRAY[0..maxlndex] OF WORD; 

END; 

END; 

VAR heapBottom, 
heapTop, 
masterPtr, 
masterBottom, 
f irstHandle-.ADDRESS; 
freeList:blockPtr; 
bIockHeaderWords, 
minBIockSize, 
masterWords:CARDINAL; 

PROCEDURE init; 

VAR heapWords:CARDINAL; 

BEGIN 

heapBottom :« getHeapBottom(); 
heapTop := getHeapTop(); 
bIockHeaderWords := TSIZE(CARDINAL); 
masterWords := TSIZE(ADDRESS); 
minBlockSize := TSIZE(bIockPtr); 


(* first word in heap *) 

(* last word in heap *) 

(* next available master *) 

(* lowest point of masters section *) 

(* first handle ever allocated *) 

(* start of free list *) 

(* # of words in a block header *) 

(* smallest value for size field of a block *) 
(* # of words occupied by a master pointer *) 
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freeList :* bIockPtr(heapBottom); 

heapWords :* cardfnaI(heapTop - heapBottom + address(l)) DIV bytesPerWord; 
freeList~.size := heapWords - bIockHeaderWords; 
freeList^.nextBlock := NIL; 
masterBottom := oneAfter(freeList); 

firstHandle :* subtractWords(masterBottom, masterWords); 
masterPtr := firstHandle; 
moreMasters; 

END init; 

PROCEDURE oneAf ter(bIockp:bIockPt r):ADDRESS; 

(* Returns the address of 1 higher than block *) 

BEGIN 

RETURN addWords(bIockp, blockp^.size + bIockHeaderWords); 

END oneAfter; 


PROCEDURE bIockSize(h:hand Ie):CARDINAL; 

BEGIN 

RETURN h^.size; 

END blockSize; 

PROCEDURE getWord(h:hand Ie; n;CARDINAL):WORD; 

BEGIN 

accessCheck(h, n); 

RETURN h~*.contents[n]; 

END getWord; 

PROCEDURE setWord(h;hand Ie; n:CARDINAL; w:WORD); 

BEGIN 

accessCheck(h, n); 
h~~.contents[n] ;= w; 

END setWord; 

PROCEDURE accessCheck(h:handIe; n:CARDINAL); 

BEGIN 

IF h~ « NIL THEN 

fata I(*at tempt to access a freed block’); 

ELSIF n >« h**.size THEN 

fata I('access out of bounds’); 

END; 

END accessCheck; 

PROCEDURE alIocate(nWords:CARDINAL):hand Ie; 

VAR master:handIe; 

BEGIN 

master := al locMasterQ; 

IF master <> NIL THEN 

master" NIL; (* do this first to prevent this master from 
being involved in compaction *) 
master^ :» a I IocBIock(nWords); 

END; 

RETURN master; 

END a I Iocate; 

PROCEDURE alIocBIock(nWords;CARDINAL);bIockPtr; 

VAR blockpiblockPtr; 

BEGIN 

blockp :» a IlocB(nWords); 

IF blockp = NIL THEN 
compact; 

blockp :* a I IocB(nWords); 

END; 

RETURN blockp; 

END a I IocBIock; 

PROCEDURE alIocB(nWords:CARDINAL):bIockPtr; 

VAR currBIock, prevBlock, newBIock;bIockPtr; 

bIockWords:CARDINAL; 

BEGIN 

IF nWords < minBlockSize THEN 

nWords minBlockSize; (* can’t allocate a smaller block than this *) 
END; 7 

bIockWords nWords + bIockHeaderWords; 


(continued) 


BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 23 



October 


currBlock :* freeLIst; 
prevBlock :■ NIL; 

WHILE currBlock <> NIL DO 

IF blockWords + mlnBlockSize <» currBIock*.size THEN 

(* spilt the block into two, returning the 1st port *) 
newBlock :■ oddWords(currBIock, blockWords); 
newBIock*.sIze :■ currBIock*.size - blockWords; 
newBlock*.nextBlock :« currBlock*.nextBlock; 

Ilnk(prevBlock, newBlock); 
currBIock*.sIze :■ nWords; 

RETURN currBlock; 

ELSIF nWords <■ currBIock*.size THEN (* return the whole block *) 

Iink(prevBlock, currBlock*.nextBlock); 

RETURN currBlock; 

END; 

prevBlock :* currBlock; 
currBlock :■ currBlock*.nextBlock; 

END (* WHILE *); 

RETURN NIL; 

END oIlocB; 

PROCEDURE ollocMoster():hondle; 

(* The strotegy here is os follows: 

1. If there is enough room between masterBottom and masterPtr to allocate 
a master, do so. 

2. If that fails, compact and allocate more masters, then try again. 

•) 

BEGIN 

IF addrLessThan(masterPtr, masterBottom) THEN 
compact; 
moreMasters; 

END; 

IF addrLessThan(masterPtr, masterBottom) THEN 
RETURN NIL; 

ELSE 

masterPtr : = subtractWords(masterPtr, masterWords); 

RETURN addWords(masterPtr, masterWords); 

END; 

END a I IocMaster; 

PROCEDURE moreMasters; 

(* Get highest block. If its top Isn’t contiguous with the masters already 
allocated, do nothing. 

Else, try to allocate nMasters from its top; if it’s too 
smaII, a I locate it all. 

*) 

VAR prev, high:bIockPtr; 

nWords: CARDINAL; 

BEGIN 

nWords := nMasters * masterWords; 

IF freeList <> NIL THEN 
high :* freeList; 
prev := NIL; 

WHILE high*.nextBlock <> NIL DO 
prev :« high; 
high :* high*.nextBlock; 

END; 

(* high now points to highest block *) 

IF oneAfter(high) * masterBottom THEN 

(* top of block is contiguous with masters *) 

IF high*.size >* minBlockSize + nWords THEN 
(* chop off nWords words from high *) 

DEC(high*.size, nWords); 
masterBottom := oneAfter(high); 

ELSIF high*.size >« minBlockSize + masterWords THEN 
(* chop of enough for one master *) 

DEC(high*.size, masterWords); 
masterBottom :* oneAfter(high); 

ELSE 

(* detach whole block *) 
link(prev, high*.nextBIock); 
masterBottom high; 

END; 

END; 

END; 

END moreMasters; 
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PROCEDURE free(VAR freeBIock:hand Ie); 

BEGIN 

freeBIk(freeBlock^); 
freeBlock^:* NIL; 
freeBlock := NIL; 

END free; 

PROCEDURE freeBlk(freeBlock:blockPtr); 

VAR currBlock, prevBIock:bIockPtr; 

BEGIN 

IF NOT addrBetween(heapBottom, freeBlock, masterBottom) THEN 
fatal("free: block not in heap"); 

ELSIF freeBlock = NIL THEN 

fatal("free: attempt to free an already freed block"); 

ELSE 

currBlock freeList; 
prevBlock := NIL; 

WHILE (currBlock <> NIL) AND addrLessThan(currBIock, freeBlock) DO 
prevBlock :» currBlock; 
currBlock :« currBIock~.nextBIock; 

END; 

IF currBlock = NIL THEN 

freeBlock^.nextBlock :* NIL; 

I ink(prevBlock, freeBlock); 

ELSE (* freeBlock belongs just before currBlock *) 
freeBlock^.nextBlock :« currBlock; 

I ink(prevBIock, freeBlock); 

END; 

tryToMerge(prevBlock, freeBlock, currBlock); 

END; 

END freeBIk; 

PROCEDURE tryToMerge(lowBlock, middleBlock, highBlockiblockPtr); 

BEGIN 

IF adjacent(middleBlock, highBlock) THEN 
merge(middIeBIock, highBlock); 

END; 

IF adjacent(IowBIock, middleBlock) THEN (* this should be impossible *) 
merge(lowBlock, middleBlock); 

END; 

END tryToMerge; 

PROCEDURE adjacent(lowerBlock, higherBIock:bIockPtr)iBOOLEAN; 

BEGIN 

RETURN 

(lowerBlock <> NIL) AND 

(higherBlock <> NIL) AND 

(oneAfter(lowerBlock) * higherBlock); 

END adjacent; 

PROCEDURE merge(IowerBIock, higherBIock:bIockPtr); 

BEGIN 

INC(IowerBIock*.size, higherBIock*.size + bIockHeaderWords); 
lowerBlock^.nextBlock := higherBIock~.nextBIock; 

END merge; 

PROCEDURE resize(h:handIe; nWords:CARDINAL); 

VAR bIockp:bIockPtr; 

BEGIN 

blockp :* a I IocBIock(nWords); 

IF blockp <> NIL THEN 

copyFromTo(h^, blockp, nWords); 

freeBlk(h^); 

h* :« blockp; 

END; 

END resize; 


PROCEDURE compact; 

(* compact blocks to low end of heap *) 

VAR lowPo1nt:bIockPtr; 

lowestHand Ie:handIe; 

BEGIN 

IF freeList <> NIL THEN 
lowPoint :* heapBottom; 

WHILE findLowestHandIeNotLowerThan(IowPoint, I owestHandIe) DO 

( continued) 
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IF lowestHandIe" <> lowPoint THEN 

IowPoint".size lowestHandle"".slze; 

copyFromTo(I owes tHandIe", IowPoint, IowPoint*.size); 

IowestHandIe" :■ lowPoint; 

END; 

lowPoint :* oneAfter(IowPo1nt); 

END; 

(* now fix free list *) 
freelist ;■ lowPoint; 

freelist".size :« (cardinaI(masterBottom-ADDRESS(freeList)) 

DIV bytesPerWord) - bIockHeaderWords; 
freelist".nextBlock :« NIL; 

END; 

END compact; 

PROCEDURE findLowestHandIeNotLowerThan(lowrblockPtr;VAR min:handle):BOOLEAN; 
VAR h:handle; 

return:BOOLEAN; 
bp: blockPtr; 

BEGIN 

h := flrstHandle; 
bp :■ blockPtr(maxAddress); 
min :■ ADR(bp); 
return :■ FALSE; 

WHILE addrLessThan(masterPtr, h) DO 

IF (NOT addrLessThon(min'', h~)) AND (NOT addrlessThon(h*. low)) THEN 
min :■ h; 
return :« TRUE; 

END; 

h :* subtractWords(h, masterWords); 

END; 

RETURN return; 

END findLowestHandIeNotLowerThan; 

PROCEDURE copyFromTo(source, dest:bIockPtr; nWords:CARDINAL); 

VAR 1:CARDINAL; ' 

BEGIN 

IF source".size < nWords THEN 
nWords :» source".size; 

END; 

FOR i :* 0 TO nWords-1 DO 

dest".contents[ i ] :® source".contents[i1; 

END; 

END copyFromTo; 

PROCEDURE Iink(prevBIock, IinkBlock:blockPtr); 

BEGIN 

IF prevBIock * NIL THEN 
freeList :* IinkBlock; 

ELSE 

prevBIock".nextBIock := IinkBlock; 

END; 

END link; 

PROCEDURE addrBetween(low, middle, high:ADDRESS):BOOLEAN; 

BEGIN 

RETURN faddrLessThanfIow, middle) OR (low = middle)) AND 
(addrLessThan(middle, high) OR (middle « high)); 

END addrBetween; 

(*** debugging stuff ***) 

PROCEDURE getFreeList():handle; 

(* for debugging only *) 

BEGIN 

RETURN hand Ie(f reeList); 

END getFreeList; 

PROCEDURE writeMap; 

VAR lowestFree, IowPoint:bIockPtr; 
lowestAIlocihandIe; 

PROCEDURE writeFree; 

BEGIN 

Wr iteStrIng( M Free M ); 

wr iteReI Address(IowestFree); 

Wr1teCard(IowestFree".size, 4); 
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Wr i teLnString(" words"); 

END writeFree; 

BEGIN (* writeMap *) 

WriteLn; 

lowestFree :« freeList; 
lowPoint :* heapBottom; 

WHILE findLowestHandleNotLowerThan(lowPoint, lowestAlloc) DO 

WHILE addrLessThan(lowestFree, lowestAlloc*) AND (lowestFree <> NIL) DO 
writeFree; 

lowestFree :* IowestFree*.nextBIock; 

END; 

Wr iteString("AIloc "); 

writeReI Address(I owestAIloc*); 

WriteCard(I owestAIloc**.size, 4); 

Wr i teLnString(" words"); 
lowPoint := oneAfter(lowestAIloc*); 

END; 

WHILE lowestFree <> NIL DO 
wr i teFree; 

lowestFree := I owestFree*.nextBIock; 

END; 

WriteLn; 

Wr i teString("firstHandIe: "); 

writeReI Address(firstHandIe); WriteLn; 

Wr i teString("masterPtr: "); 

writeReI Address(masterPtr); WriteLn; 

Wr i teString("masterBottom: "); 
wrlteRelAddress(masterBottom); WriteLn; 

END writeMap; 

PROCEDURE writeReI Address(a:ADDRESS); 

BEGIN 

WriteCard(cardinaI(a - heapBottom), 4); 

END wr1teReI Address; 

BEGIN 

init; 

END Alloc3. 


ALL0C4.DEF 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


DEFINITION MODULE Alloc4; 

(* A safe storage allocator using the first-fit method and capabilities. 
Copyright 1986 by Jonathan Amsterdam. All Rights Reserved. *) 

FROM SYSTEM IMPORT WORD; 

EXPORT QUALIFIED capability, blockSize, getWord, setWord, allocate, free, 
getFreeList, resize, writeMap; 

TYPE capability; (* offset to a pointer, and generation count*) 

PROCEDURE bIockSize(c:capabiIity):CARDINAL; 

(* Size of block *) 

PROCEDURE getWord(c:capabiIity; n:CARDINAL):WORD; 

(* Returns n’th word of block. Block indexed from 0 to blockSize-1; 
dies If n > blockSize-1. *) 

PROCEDURE setWord(c:capabiIity; mCARDINAL; w:WORD); 

(* sets n’th word of block to w; dies if n > blockSize-1. *) 

PROCEDURE a I Iocate(nWords:CARDINAL):capabI Iity; 

(* allocates a block of nWords words (possibly slightly more, in some cases) *) 
PROCEDURE free(VAR freeBIock;capabiIity); 


(continued) 
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(* frees block pointed to by freeBlock if it points into the heap, and sets 
freeBlock to NIL. *) 

PROCEDURE resize(c:capabiIity; nWords:CARDINAL); 

(* attempts to change size of block referenced by h *) 

PROCEDURE writeMap; 

(* Writes, in order of address, the free and allocated blocks ond their 
sizes. For debugging only; should be removed in "production" versions 
of the a I Iocator. *) 

PROCEDURE getFreeList():capabiIity; (* really a blockPtr *) 

(* Returns a pointer to the free list. For debugging only. This should 
be removed in "production" versions of the allocator. *) 

END AI Ioc4. 


ALL0C4.M0D 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


IMPLEMENTATION MODULE Alloc4; 


(* A storage allocator that tries to be safe about freed blocks. 

It uses capabilities to keep track of blocks. 

It also compacts space, and allows resizing. 

A capability is a generation count and an offset into the heap. The offset 
is used to find the master capability. 

Copyright 1986 by Jonathan Amsterdam. All Rights Reserved. *) 

FROM SYSTEM IMPORT WORD, ADDRESS, TSIZE, ADR; 

FROM MachineSpec1fic IMPORT getHeapBottom, getHeapTop, bytesPerWord, 

address, cardinal, addrLessThan, wrIteAddress, addWords, subtractWords, 
maxAddress; 

FROM MyTerminal IMPORT fatal, WriteLnString, WriteCard, 

WrlteStrlng, WrlteLn; 

CONST maxlndex « 32767; 

nMasters « 10; (* number of masters to allocate each time more needed *) 


TYPE capability = ADDRESS; 

capRec = RECORD (* used to get the components of a capability *) 

CASE BOOLEAN OF 

TRUE: genCountCARDINAL; 

offset: CARDINAL; 

FALSE: cap:capabiIity; 

END; 

END; 

handle = POINTER TO masterCap; 

blockPtr = POINTER TO block; f 

masterCap * RECORD 

genCount:CARDINAL; 

CASE BOOLEAN OF 

TRUE: nextMaster:handIe; 

| FALSE: bIockp:bIockPtr; 

END; 

END; 

block * RECORD 

size CARDINAL; (* not including header *) 

CASE BOOLEAN OF 

TRUE: nextBlock: blockPtr; 

| FALSE: contents:ARRAY[0..maxlndex] OF WORD; 

END; 

END; 


VAR heapBottom, (* 

heapTop, (* 

masterBottom, (★ 

firstMaster:ADDRESS; (* 

freeList .-blockPtr; (* 

masterPtr, (* 

masterFreeList:handle; (* 


first word in heap *) 

last word in heap *) 

lowest point of masters section *) 

first master ever allocated *) 

start of free list *) 

next available master *) 

start of master free list *) 
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bIockHeaderWords, 
minBIockSi ze, 
masterWords:CARDINAL; 
cr icapRec; 


(* # of words In a block header *) 

(* smallest value for size field of a block *) 

(* # of words occupied by a master capability *) 
(* a dummy record used for capabilities *) 


PROCEDURE init; 

VAR heapWords:CARDINAL; 

BEGIN 

heapBottom getHeapBottom(); 
heapTop :« getHeapTop(); 
bIockHeaderWords := TSIZE(CARDINAL); 
masterWords := TSIZE(masterCap); 
minBlockSize :* TSIZE(blockPtr); 
freeList :« blockPtr(heapBottom); 

heapWords := cardinaI(heapTop - heapBottom + address(l)) DIV bytesPerWord; 
freeList".size :* heapWords - bIockHeaderWords; 
freeList".nextBlock :« NIL; 
masterBottom :* oneAfter(freeList); 

firstMaster :» subtractWords(masterBottom, masterWords); 
masterPtr := hand Ie(firstMaster); 
masterFreeList ;* NIL; 
moreMasters; 

END init; 


PROCEDURE oneAfter(bIockp:bIockPtr);ADDRESS; 

(* Returns the address of 1 higher than block *) 

BEGIN 

RETURN addWords(blockp, blockp".size + bIockHeaderWords); 
END oneAfter; 


PROCEDURE blockSize(c:capabiIity):CARDINAL; 

VAR blockpiblockPtr; 

BEGIN 

blockp :* getBlock(c); 

RETURN bIockp".size; 

END blockSize; 

PROCEDURE getWord(c:capabiIity; n:CARDINAL):WORD; 

VAR blockpiblockPtr; 

BEGIN 

blockp :* getBlock(c); 
accessCheck(bIockp, n); 

RETURN bIockp".contents[n]; 

END getWord; 

PROCEDURE setWord(c:capobiIity; n:CARDINAL; w:WORD); 

VAR blockpiblockPtr; 

BEGIN 

blockp := getBlock(c); 
accessCheck(bIockp, n); 
blockp".contents[n] :« w; 

END setWord; 

PROCEDURE getBlock(c:capabiIity):bIockPtr; 

VAR master:hand Ie; 

BEGIN 

master :■ getMaster(c); 

RETURN master".blockp; 

END getBlock; 

PROCEDURE getMaster(cicapablIity);handle; 

VAR cricopRec; 

master:handIe; 

BEGIN 

cr.cap :* c; 

master :« hand Ie(subtractWords(firstMaster, cr.offset)); 

IF cr.genCount <> master".genCount THEN 
fatal(’generation counts disagree’); 

ELSE 

RETURN moster; 

END; 

END getMaster; 

PROCEDURE accessCheck(blockp:blockPtr; n:CARDINAL); 

(continued) 
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BEGIN 

IF n >- bIockp".size THEN 

fata I(’access out of bounds’); 

END; 

END accessCheck; 

PROCEDURE a I Iocate(nWords:CARDINAL):capabiIIty; 

VAR cr:capRec; 

master:hand Ie; 

BEGIN 

master :■ a I IocMaster(); 

IF master <> NIL THEN 

master".blockp :* NIL; (* do this first to prevent this master from 

being involved in compaction *) 
master".bIockp := allocBlock(nWords); 

END; 

cr.genCount :* master".genCount; 

cr.offset := cardinaI(firstMaster - ADDRESS(master)) DIV bytesPerWord; 
RETURN cr.cap; 

END allocate; 

PROCEDURE alIocBIock(nWords:CARDINAL):bIockPtr; 

VAR blockprblockPtr; 

BEGIN 

blockp :* a I IocB(nWords); 

IF blockp = NIL THEN 
compact; 

blockp :« a IlocB(nWords); 

END; 

RETURN blockp; 

END a IlocBlock; 

PROCEDURE alIocB(nWords:CARDINAL):blockPtr; 

VAR currBlock, prevBlock, newBIock:bIockPtr; 

bIockWords:CARDINAL; 

BEGIN 

IF nWords < minBlockSize THEN 

nWords :® minBlockSize; (* can't allocate a smaller block than this * 

END; 

blockWords :* nWords + bIockHeaderWords; 
currBlock := freeList; 
prevBlock :* NIL; 

WHILE currBlock <> NIL DO 

IF blockWords + minBlockSize <* currBlock".size THEN 

(* split the block into two, returning the 1st part *) 
newBlock :■ addWords(currBlock, blockWords); 
newBlock".size :« currBlock".size - blockWords; 
newBlock".nextBlock := currBlock".nextBlock; 

Iink(prevBlock, newBlock); 
currBlock".size := nWords; 

RETURN currBlock; 

ELSIF nWords <- currBlock".size THEN (* return the whole block *) 

Ilnk(prevBIock, currBlock".nextBlock); 

RETURN currBlock; 

END; 

prevBlock :* currBlock; 
currBlock :» currBIock".nextBIock; 

END O WHILE *); 

RETURN NIL; 

END a IlocB; 

PROCEDURE a I IocMaster():handIe; 

(* The strategy here is as follows: 

1. If the master free list isn’t empty, take the first master. 

2. If there is enough room between masterBottom and masterPtr to ollocate 
a master, do so. 

3. If that fails, compact and allocate more masters, then try again. 

*) 

VAR h:handle; 

BEGIN 

IF masterFreeList <> NIL THEN 
h := masterFreeList; 

masterFreeList :* masterFreeList".nextMaster; 

RETURN h; 

ELSE 


30 BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER 1986 






October 


IF addrLessThan(masterPtr, masterBottom) THEN 
compact; 
moreMasters; 

END; 

IF addrLessThan(mosterPtr, masterBottom) THEN 
RETURN NIL; 

ELSE 

masterPtr^.genCount := 0; 

masterPtr hand Ie(subtractWords(masterPtr, masterWords)); 

RETURN addWords(masterPtr, masterWords); 

END; 

END; 

END allocMaster; 

PROCEDURE moreMasters; 

(* Get highest block. If its top isn't contiguous with the masters already 
allocated, do nothing. 

Else, try to allocate nMasters from its top; if it’s too 
smaII, allocate it all. 

*) 

VAR prev, high:bIockPtr; 

nWordsCARDINAL; 

BEGIN 

nWords := nMasters * masterWords; 

IF freeList <> NIL THEN 
high :■ freeList; 
prev :• NIL; 

WHILE high A .nextBIock <> NIL DO 
prev :» high; 
high high*.nextBIock; 

END; 

(* high now points to highest block *) 

IF oneAfter(high) ■ masterBottom THEN 

(* top of block is contiguous with masters *) 

IF high^.size >■ minBlockSize + nWords THEN 
(* chop off nWords words from high *) 

DEC(high A .size, nWords); 
masterBottom :» oneAfter(high); 

ELSIF high^.size >* minBlockSize + masterWords THEN 
(* chop of enough for one master *) 

DEC(high*.size, masterWords); 
masterBottom :■ oneAfter(high); 

ELSE 

(* detach whole block *) 
link(prev, high^.nextBIock); 
masterBottom :■ high; 

END; 

END; 

END; 

END moreMasters; 


PROCEDURE free(VAR c:capabiIity); 

(* Return the block to the free list; put the master on the master free list.*) 

VAR master:handIe; 

BEGIN 

master :■ getMaster(c); 
freeBIk(master*.bIockp); 

INC(master*.genCount); 

master^.nextMaster :* masterFreeList; 

masterFreeList :» master; 

END free; 

PROCEDURE freeBIk(freeBIock:bIockPtr); 

VAR currBlock, prevBIock:bIockPtr; 

BEGIN 

IF NOT addrBetween(heapBottom, freeBlock, masterBottom) THEN 
fatal("free: block not in heap"); 

ELSIF freeBlock - NIL THEN 

fatal("free; attempt to free an already freed block"); 

ELSE 

currBlock :■ freeList; 
prevBlock :■ NIL; 

WHILE (currBlock <> NIL) AND addrLessThan(currBlock, freeBlock) DO 
prevBlock :■ currBlock; 

(continued) 
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currBlock :■ currBlock".nextBlock; 

END; 

IF currBlock ■ NIL THEN 

freeBlock".nextBlock :■ NIL; 

I Ink(prevBIock, freeBlock); 

ELSE (* freeBlock belongs Just before currBlock *) 
freeBlock".nextBlock currBlock; 

I Ink(prevBIock, freeBlock); 

END; 

tryToMerge(prevBIock, freeBlock, currBlock); 

END; 

END freeBIk; 


PROCEDURE tryToMerge(IowBlock, mlddIeBIock, hIghBIock:bIockPtr); 

BEGIN " 

IF odjocent(mIddIeBIock, highBlock) THEN 
merge(middIeBIock, highBlock); 

END; 

IF adjoc«nt(IowBlock, middIeBIock) THEN (* this should be impossible *) 
merge(lowBlock, middleBlock); 

END; 

END tryToMerge; 


PROCEDURE adjacent(IowerBIock, higherBlock:blockPtr):BOOLEAN- 
BEGIN 
RETURN 

(lowerBlock <> NIL) AND 

(higherBlock <> NIL) AND 

(oneAfter(lowerBlock) * hIgherBIock); 

END adjacent; 

PROCEDURE merge(lowerBlock. higherBIock:bIockPtr): 

BEGIN ' 

INC(IowerBIock'*.size, higherBIock".size + blockHeaderWords)- 
lowerBlock".nextBlock := higherBlock".nextBlock; 

END merge; 

PROCEDURE res Ize(c:capablIity; nWords:CARDINAL); 

VAR blockp:blockPtr; 

master:handIe; 

BEGIN 

master := getMaster(c); 
blockp := allocBlock(nWords); 

IF blockp <> NIL THEN 

copyFromTo(master".blockp, blockp, nWords); 
freeBIk(master".bIockp); 
master".blockp :* blockp; 

END; 

END resize; 


PROCEDURE compact; 

(* compact blocks to low end of heap *) 

VAR lowPoint:bIockPtr; 

I owestHand Ie:hand Ie; 

BEGIN 

IF freeList <> NIL THEN 
lowPoInt :» heapBottom; 

WHILE fIndLowestHandIeNotLowerThan(IowPoint, I owestHandIe) DO 
IF lowestHandle".blockp <> lowPoint THEN 

lowPoint".size := lowestHandle".blockp".size; 

copyFromTo(I owestHandIe".bIockp, IowPoint, IowPoint".size); 

lowestHandle".blockp := lowPoint; 

END; 

lowPoint := oneAfter(IowPoint); 

END; 

(* now flx free list *) 
freeList := lowPoint; 

freeList".size (cardinal(masterBottom-ADDRESS(freeList)) 

DIV bytesPerWord) - blockHeaderWords; 
freeList".nextBlock :* NIL; 

END; 

END compact; 

PROCEDURE findLowestHandIeNotLowerThan(Iow:bIockPtr;VAR min:hand Ie):BOOLEAN; 
(* The IF condition in the loop checks three things: 1. the handle under 
consideration Is <- than the current minimum; 2. it is >* the low point; 

32 BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 



October 


3. it is < masterBottom (hence not part of the master free list). 

*) 

VAR hihandle; 

return:BOOLEAN; 
me: masterCap; 

BEGIN 

h :* firstMaster; 

mc.blockp :« blockPtr(maxAddress); 
min := ADR(me); 
return FALSE; 

WHILE addrLessThan(masterPtr, h) DO 

IF (NOT addrLessThan(min".blockp, h".blockp)) AND 
(NOT addrLessThan(h".blockp, low)) AND 
addrLessThan(h".blockp, masterBottom) THEN 
min :« h; 
return :* TRUE; 

END; 

h := subtractWords(h, masterWords); 

END; 

RETURN return; 

END findLowestHandIeNotLowerThan; 

PROCEDURE copyFromTo(source, dest:bIockPtr; nWords:CARDINAL); 

VAR i:CARDINAL; 

BEGIN 

IF source".size < nWords THEN 
nWords :* source".size; 

END; 

FOR 1 :« 0 TO nWords-1 DO 

dest".contents[i] :* source".contents[i]; 

END; 

END copyFromTo; 

PROCEDURE Iink(prevBlock, IinkBIock:bIockPtr); 

BEGIN 

IF prevBlock * NIL THEN 
freeList :■ I inkBlock; 

ELSE 

prevBlock".nextBlock :* IinkBlock; 

END; 

END link; 

PROCEDURE addrBetween(Iow, middle, high:ADDRESS):BOOLEAN; 

BEGIN 

RETURN (addrLessThan(Iow, middle) OR (low = middle)) AND 
(addrLessThan(middIe, high) OR (middle = high)); 

END addrBetween; 

(*** debugging stuff ***) 

PROCEDURE getFreeLIst():capabiIity; 

(* for debugging only *) 

BEGIN 

RETURN capabiIity(freeList); 

END getFreeList; 

PROCEDURE writeMap; 

VAR lowestFree, lowPoint:bIockPtr; 
lowestAIloc:handIe; 

PROCEDURE writeFree; 

BEGIN 

WriteString("Free "); 

writeReI Address(lowestFree); 

WriteCard(lowestFree".size, A); 

WriteLnString( M words"); 

END writeFree; 

BEGIN (* writeMap *) 

WriteLn; 

lowestFree :■ freeList; 
lowPoint :* heapBottom; 

WHILE fIndLowestHandIeNotLowerThan(IowPoint, lowestAIloc) DO 
WHILE addrLessThan(IowestFree, lowestAIloc".blockp) 

AND (lowestFree <> NIL) DO 

( continued) 
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wrIteFree; 

lowestFree := IowestFree*.nextBIock; 

END; 

WrIteString("AIloc M ); 

wrIteReI Address(I owestAIloc^.blockp); 

WrIteCord(IowestAIIoc*.bIockp A .size, 4); 

WrIteStrIng(" words; gen. count - "); 

WrIteCord(IowestAIIoc~.genCount, 0); WrfteLn; 
lowPolnt :■ oneAfter(IowestAIIoc*.bIockp); 

END; 

WHILE lowestFree <> NIL DO 
wr i teFree; 

lowestFree ;■ I owestFree*.nextBIock; 

END; 

WrlteLn; 

Wr IteLnStrIng("master free list:"); 
lowestAIloc :■ masterFreeList; 

WHILE lowestAIloc <> NIL DO 

wrIteReIAddress(lowestAIloc); 
lowestAIloc :• lowestAIIoc*.nextMaster; 

END; 

Wr I teLn; 

WriteString("fIrstMaster: "); 

wrIteReI Address(fIrstMoster); WriteLn; 

WriteStrlng("masterPtr: "); 

wrIteReI Address(masterPtr); WrIteLn; 

WrIteStrlng("masterBottom: "); 

wrIteReI Address(masterBottom); WrIteLn; 

END wrIteMap; 

PROCEDURE wrIteReI Address(a:ADDRESS); 

BEGIN 

WrlteCard(cardinal(a - heapBottom), 4); 

END wrIteReI Address; 

BEGIN 

inlt; 

END AI Ioc4. 


MYTERMIN.MOD 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


IMPLEMENTATION MODULE MyTerminal; 

(* Some small but useful additions to the Terminal module. *) 
IMPORT TerminaI; 

VAR powerOfTen: ARRAY[0..4] OF CARDINAL; 


PROCEDURE WrIteLnStrIng(s:ARRAY OF CHAR); 

BEGIN 

Terminal.WriteString(s); 

TerminaI.WrIteLn; 

END WriteLnString; 

PROCEDURE Writelnt(i:INTEGER; spaces CARDINAL); 
BEGIN 

IF I < 0 THEN 

wrIteNum(CARDINAL(-i), spaces-1, TRUE); 

ELSE 

wrIteNum(CARDINAL(I), spaces, FALSE); 

END; 

END Writelnt; 

PROCEDURE WriteCard(c, spaces CARDINAL); 

BEGIN 

writeNum(c, spaces, FALSE); 

END WriteCard; 
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PROCEDURE writeNum(c, spaces:CARDINAL; neg:BOOLEAN); 

VAR p:CARDINAL; 

i;INTEGER; 

BEGIN 

p :« pI aces(c); 

FOR i :« 1 TO INTEGER(spaces) - INTEGER(p) DO 
TerminaI.WrIte(' '); 

END; 

IF neg THEN 

TerminaI.WrIte(; 

END; 

FOR i := p-1 TO 0 BY -1 DO 

Terminal.Write(CHR((c DIV powerOfTen[i]) + ORD(’0’))); 
c :* c MOD powerOfTen[i]; 

END; 

END writeNum; 

PROCEDURE pIaces(c:CARDINAL);CARDINAL; 

(* Returns the number of places c takes to print; i.e. trunc(1+log10(c)). *) 
VAR i:CARDINAL; 

BEGIN 

FOR i ;* 4 TO 0 BY -1 DO 

IF (c DIV powerOfTen[i]) > 0 THEN 
RETURN 1+1; 

END; 

END; 

RETURN 1; 

END places; 


PROCEDURE pause(msg:ARRAY OF CHAR); 

(* Prevents the screen from blanking and returning to the Finder until the 
user hits a key. msg is typed out. *) 

VAR ch:CHAR; 

BEGIN 

Terminal.WriteString(msg); 

TerminaI.Read(ch); 

END pause; 

PROCEDURE fatal(msg;ARRAY OF CHAR); 

BEGIN 

WriteLnString(msg); 
pause('Hit any key to die—’); 

HALT; 

END fatal; 


(*** Copies of Terminal procedures ***) 

PROCEDURE WriteString(s;ARRAY OF CHAR); 

BEGIN 

Terminal.WriteString(s); 

END WriteString; 

PROCEDURE WriteLn; 

BEGIN 

TerminaI.WriteLn; 

END WriteLn; 

PROCEDURE Write(c;CHAR); 

BEGIN 

TerminaI.Write(c); 

END Write; 

PROCEDURE Read(VAR c;CHAR); 

BEGIN 

TerminaI.Read(c); 

END Read; 

PROCEDURE ClearScreen; 

BEGIN 

Terminal.ClearScreen; 

END ClearScreen; 

PROCEDURE Beep; 

BEGIN 

(continued) 
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Term!no I.Beep; 
END Beep; 

BEGIN 


powerOfTen 

0 

:* 1; 

powerOfTen 

Y 

:- 10; 

powerOfTen 

' 2 ' 

100; 

powerOfTen 

'3' 

:« 1000; 

powerOfTen 

Y 

10000; 


END MyTerminaI. 


MYTERMIN.DEF 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


DEFINITION MODULE MyTermlnal; 

(* Some small but useful additions to the Terminal module. *) 

EXPORT QUALIFIED WrlteString, WriteLn, Write, Read, ClearScreen, Beep, 

WrIteLnString, Writelnt, WriteCard, pause, fatal; 

PROCEDURE WriteString(s:ARRAY OF CHAR); 

PROCEDURE WriteLn; 

PROCEDURE Write(ciCHAR); 

PROCEDURE Read(VAR c:CHAR); 

PROCEDURE ClearScreen; 

PROCEDURE Beep; 

PROCEDURE WriteLnStrIng(s:ARRAY OF CHAR); 

PROCEDURE Writelnt(I:INTEGER; spacesrCARDINAL); 

PROCEDURE WriteCard(c, spaces:CARDINAL); 

PROCEDURE pause(msg:ARRAY OF CHAR); 

(* Prevents the screen from blanking and returning to the Finder until the 
user hits a key. msg is typed out. *) 

PROCEDURE fatal(msg:ARRAY OF CHAR); 

(* Prints the message, does a pause, and HALTs. *) 

END MyTerminaI. 


MACHINES.MOD 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


IMPLEMENTATION MODULE MachineSpecific; 

FROM SYSTEM IMPORT WORD, ADDRESS, ADR; 

FROM InOut IMPORT WriteHex; 

CONST heapSize * 100; (* size of heap in words *) 

maxCard * 0FFFFh; (* maximum cardinal value *) 

TYPE fool Record - RECORD 

CASE BOOLEAN OF 

TRUE: h, I:CARDINAL; 

| FALSE: a:ADDRESS; 

END; 

END; 

VAR heap:ARRAY[1..heapSize] OF WORD; 
foolRec, foolRec2: foolRecord; 

PROCEDURE getHeapBottom():ADDRESS; 

BEGIN 

RETURN ADR(heap[1]); 

END getHeapBottom; 
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PROCEDURE getHeapTop():ADDRESS; 

BEGIN 

RETURN ADR(heap[heapsize]); 

END getHeapTop; 

PROCEDURE address(w:WORD);ADDRESS; 

BEGIN 

foolRec.h := 0; 
foolRec.l ;= CARDINAL(w); 

RETURN foolRec.a; 

END address; 

PROCEDURE cardinal (a-.ADDRESS) :CARDINAL; 

(* * assumes address is small enough *) 

BEGIN 

foolRec.a :* a; 

RETURN foolRec.I; 

END cardinaI; 

PROCEDURE addrLessThan(a1, a2:ADDRESS):BOOLEAN; 

BEGIN 

foolRec.a :« al; 
foolRec2.a := a2; 

RETURN (foolRec.h < foolRec2.h) OR 

((foolRec.h * foolRec2.h) AND (foolRec.l < fooIRec2.I)); 
END addrLessThan; 

PROCEDURE writeAddress(a:ADDRESS); 

BEGIN 

foolRec.a :■ a; 

WriteHex(fooIRec.h, 0); 

Wr1teHex(fooIRec.I, 0); 

END writeAddress; 

PROCEDURE addWords(a:ADDRESS; nWords:CARDINAL):ADDRESS; 

BEGIN 

RETURN a + address(bytesPerWord*nWords); 

END addWords; 

PROCEDURE subtractWords(a:ADDRESS; nWords:CARDINAL);ADDRESS; 

BEGIN 

RETURN a - address(bytesPerWord*nWords); 

END subtractWords; 


BEGIN 

foolRec.I :» maxCard; 
foolRec.h :« maxCard; 
maxAddress :» foolRec.a; 
END MachineSpecIfic. 


MACHINES.DEF 

Programming Project: "Safe Storage Allocation," by 
Jonathan Amsterdam, October 1986, page 122. 


DEFINITION MODULE MachineSpecific; 

(* These routines are specific to the computer being used to run the program. 

Most of the problems on the Mac stem from the facts that the unit of 
addressing is the byte, not the word, and that an address is 32 bits while 
a word is only 16. 

*) 

FROM SYSTEM IMPORT WORD. ADDRESS; 

EXPORT QUALIFIED getHeapBottom, getHeapTop, bytesPerWord, address, cardinal, 
addrLessThan, writeAddress, addWords, subtractWords, maxAddress; 

CONST bytesPerWord - 2; 

VAR maxAddress:ADDRESS; (* largest address on the machine *) 

( continued ) 
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PROCEDURE getHeapBot tom():ADDRESS; 

(* Returns address of lowest byte In heap *) 

PROCEDURE getHeapTop():ADDRESS; 

(* Returns address of highest byte In heap *) 

PROCEDURE address(w:WORD):ADDRESS; 

(* converts a word (16 bits on a Mac) Into an address (32 bits) *) 

PROCEDURE cardinal(a:ADDRESS):CARDINAL; 

(* converts the low-order 16 bits of an address (on a Mac) to a cardinal *) 

PROCEDURE addrLessThan(a1, a2:ADDRESS):BOOLEAN; 

(* Returns true If al Is less than a2 *) 

PROCEDURE writeAddress(a:ADDRESS); 

(* writes the address in hex *) 

PROCEDURE addWords(a:ADDRESS; nWords :CARDINAL)-.ADDRESS; 

(* adds nWords Modula-2 words to the address *) 

PROCEDURE subtractWords(a:ADDRESS; nWords:CARDINAL):ADDRESS; 

(* subtracts nWords Modula-2 words from the address *) 

END MachineSpecific. 


LINETEST.MOD 

"ITC’s Modula-2 Software Development System," by Mark 
Bridger, October 1986, page 255. 


MODULE LineTest; 

FROM InOut IMPORT Write; 

FROM Geometry IMPORT Point; 

FROM Screen IMPORT Colors, VideoStates, Back, Fore, GraphColor, 
SetVideo, SetPalette, DrawLine; 

VAR 

I, J 2 CARDINAL; 

PROCEDURE LINE(x1, yl. x2. y2. color : CARDINAL); 

VAR 

P. Q ; Point; 

BEGIN 

WITH P DO 
x : ■ x 1; 

y yl; 

END; 

WITH Q DO 
x :■ x2; 
y := y2; 

END; 

GraphColor ;= color; 

DrawLine(P, Q); 

END LINE; 

BEGIN 

SetVideo(MedRes); 

Back :* Blue; 

SetPaIette(1); 

FOR i :« 0 TO 15 DO 
FOR j 0 TO 9 DO 

LINE(20*i, 20*j, 319-20*i, 199-20*j, i + j); 

END; 

END; 

Wr i te(07C); 

SetVideo(Text80); 

END LineTest. 
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BTRANS.MOD 

"ITC's Modula-2 Software Development System," by Mark 
Bridger, October 1986, page 255. 


MODULE BTrans; 

FROM InOut IMPORT Write; . 

FROM Files IMPORT File, WriteNBytes, ReadNBytes, Create, Close, Open, 
Wmode, Rmode. status, FileStatus; 

FROM SYSTEM IMPORT ADR, SIZE; 

VAR 

F, G : File; 

Buffer : ARRAY [1..128] OF CHAR; 

J : CARDINAL; 

EOF : BOOLEAN; 

BEGIN 

F := Open("INFILE.TXT",Rmode); 

EOF :« (status = EndOfFile); 

G CreateCOUTFILE.TXT",Wmode); 

WHILE NOT(EOF) DO 

J :« ReodNBytes(F,ADR(Buf fer),SIZE(Buf f er)) ; 

EOF := (J » 0); 

IF NOT(EOF) THEN 

WriteNBytes(G, ADR(Buffer), SIZE(Buffer)); 

END; 

END; 

Close(F); 

Close(G); 

Write(07C); 

END BTrons. 


CALC.MOD 

"ITC's Modula-2 Software Development System," by Mark 
Bridger, October 1986, page 255. 


MODULE CaIc87; 

FROM InOut IMPORT Write, WriteString; 
FROM Rea IInOut IMPORT WriteReal; 

VAR 

~ A, B, C : REAL; 

N, I ; INTEGER; 

BEGIN 

N :« 5000; 

A 2.71828; 

B 3.14159; 

C :* 1.0; 

FOR I 1 TO N DO 
C :* C*A; 

C :■ C*B; 

C C/A; 

C :« C/B; 

END; 

Write(07C); 

WriteString("Error - "): 

WriteReoI(C - 1.0. 8); 

END Colc87. 


(continued) 
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FLOAT.MOD 

"ITC’s Modula-2 Software Development System," by Mark 
Brldger, October 1986, page 255. 


MODULE Float; 

FROM MothtibO IMPORT sin, In, exp, sqrt, arctan; 

VAR 

I : CARDINAL; 
x, y : REAL; 

BEGIN 

x :« 1.0; 

FOR I 1 TO 1000 DO 
y sin(x); 
y ln(x); 
y exp(x); 
y :« sqrt(x); 
y :* arctan(x); 
x ;■ x + 0.01; 

END; 

END Float. 


TRANS.MOD 

"ITC’s Modula-2 Software Development System," by Mark 
Bridger, October 1986, page 255. 


MODULE Trans; 

FROM InOut IMPORT Write; 

FROM Files IMPORT File, WrlteNBytes, ReadNBytes, Create, Close, Open, 
Wmode, Rmode, status, FileStatus; 

FROM SYSTEM IMPORT ADR, SIZE; 

VAR 

F, G : FIle; 
ch : CHAR; 

EOF : BOOLEAN; 

J : CARDINAL; 

BEGIN 

F :* Open("INFILE.TXT",Rmode); 

EOF := (status « EndOfFile); 

G := Create("OUTFILE.TXT",Wmode); 

WHILE NOT(EOF) DO 

J :« ReadNBytes(F,ADR(ch),SIZE(ch)); 

EOF (J - 0); 

IF NOT(EOF) THEN 

WriteNBytes(G, ADR(ch), SIZE(ch)); 

END; 

END; 

ClosefF}; 

Close(G); 

Wr i te(07C); 

END Trans. 


SIEVE.MOD 

"ITC’s Modula-2 Software Development System," by Mark 
Bridger, October 1986, page 255. 


MODULE Sieve; 

FROM InOut IMPORT Write, WriteLn, WriteCard, WriteString; 
CONST 

Size = 7001; 

VAR 

Flags : ARRAY [0..Size] OF BOOLEAN; 

I, Prime, K, Count, Iter : CARDINAL; 
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BEGIN 

Wr i teString("Start first iteration."); 
FOR Iter := 1 TO 10 DO 
Count 0; 

FOR I 0 TO Size DO 

Flagsfl] :* TRUE; 

END; 

FOR I :* 0 TO Size DO 
IF FIags[I] THEN 
Prime :* I + I +3; 

K :* I + Prime; 

WHILE K <= Size DO 
FIags[K] :« FALSE; 

K := K + Prime; 

END; 

Count := Count + 1; 

END; 

END; 

WriteCard(Count, 1); 

Wr i teLn(); 

END; 

Wr i te(07C); 

END Sieve. 


HEAPTEST.MOD 

"ITC’s Modula-2 Software Development System," by Mark 
Brldger, October 1986, page 255. 


MODULE heaptest; 

FROM Storage IMPORT ALLOCATE, DEALLOCATE; 
FROM InOut IMPORT Write, Writelnt, WriteLn; 
CONST 

MaxSize = 53; 

TYPE 

Strings « ARRAY [1..9999] OF CHAR; 
BufferType «= POINTER TO Strings; 

VAR 

Buffer : ARRAY [0..MaxSize] OF BufferType; 
I : INTEGER; 

BEGIN 

FOR I :« 1 TO MaxSize DO 
NEW(Buffer[I]) ; 

END; 

DISPOSE(Buffer[MaxSize]); 

FOR I :■ 1 TO (MaxSize - 1) DIV 2 DO 
DISPOSE(Buf fer[2*1]); 

END; 

NEW(Buf fer[MaxSize]); 

FOR I :« 1 TO (MaxSize - 1) DIV 2 DO 
NEW(Buf fer[2*1]); 

END; 

FOR I 1 TO (MaxSize - 1) DIV 2 DO 
DISPOSE(Buf fer[2*1 - 1]); 

END; 

DISPOSE(Buf fer[MaxSize]); 

NEW(Buf fer[0]); 

FOR I :« 1 TO (MaxSize - 1) DIV 2 DO 
NEW(Buf fer[2*1 - 1]); 

END; 

Write(07C); 

END heaptest. 


(continued) 
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CROSS.OAT 

"An ICON Tutorial *" by Ralph E. Griswold and Madge T. 
Griswold, October 1986, page 167. 


e I ephants:peanuts 
encroachment:roaches 
goggIe:geese 


TROUBLE.FRM 

"An ICON Tutorial," by Ralph E. Griswold and Madge T. 
Griswold, October 1986, page 167. 


Trouble Report for Version 5.9 of Icon for MS-DOS (SMM) 


Name 

Address 


Telephone _ 

Electronic mall address _ 

Computer _ 

Operating system _ 

Date _ 

Description of the problem: 


Attach additional information, listings, enclose source code, etc 
as appropriate. Send to: 

Icon Project 

Department of Computer Science 
The University of Arizona 
Tucson, Arizona 85721 

September 10, 1985 


WORDCNT.ICN 

"An ICON Tutorial," by Ralph E. Griswold and Madge T. 
Griswold, October 1986, page 167. 


# WORD COUNTING 

# 

# This program tabulates the words in standard input and writes the 
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# results with the words in a column 20 characters wide. The definition 
| of a "word” is naive. 

procedure mainQ 
wordcount(20) 

end 

procedure wordcount(n) 
locaI t, line, x, y 
static letters 

initial letters :* Release ++ fcucase 

t := tab Ie(0) 

while line := read() do 

line ? while tab(upto(Ietters)) do 
t[tab(many(letters))] +:= 1 
x sort(t) 

every y :* !x do write(Ieft(y[1],n),y[2]) 

end 


CROSS.ICN 

"An ICON Tutorial," by Ralph E. Griswold and Madge T. 
Griswold, October 1986, page 167. 


# 

# WORD INTERSECTIONS 

# 

§ This program procedure accepts string pairs from standard input, with 
| the strings separated by semicolons. It then diagrams all the 
# intersections of the two strings in a common character. 

procedure main() 

I oca I line, j 

while line :* read() do { 
wr 1te() 

j := upto(*:*,Iine) 
cross(line[1:j ],Iine[J+1:0]) 

I 

end 

procedure cross(s1,s2) 
local j, k 

every j := upto(s2,sl) do 

every k := upto(s1[ i ],s2) do 
xprint(si,s2,j,k; 

end 

procedure xprint(s1,s2,j,k) 
wr l te() 

every write(right(s2[1 to k-1],j)) 
wr i te(s1) 

every write(right(s2[k+1 to *s2],j)) 

end 


EXTEN.DOC 

"An ICON Tutorial," by Ralph E. Griswold and Madge T. 
Griswold, October 1986, page 167. 


Extensions to Version 5 of the Icon 
Programming Language 


1. Introduction 

The standard features of Version 5 of Icon are described in 
Reference 1. Since Icon is the byproduct of a research effort 
that is concerned with the development of novel programming 

( continued ) 
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language facilities for processing nonnumeric data, it is inevit¬ 
able that some extensions to the standard language will develop. 

Some of these extensions are Incorporated as features of new 
releases. Others are available as options that can be selected 
when the Icon system is installed. This report describes the 
extensions that are included in Version 5.9 of Icon. 

All the extensions are upward-compatible with standard Version 
5 Icon. Their inclusion should not interfere with any progrom 
that works properly under the standard version. 


2. New Version 5.9 Features 
2.1 The Link Directive 

Version 5.9 contains a link directive that simplifies the 
inclusion of separately translated libraries of Icon procedures. 
If icont is run with the -c option, source files are translated 
into intermediate ucode files (with names ending in .ul and .u2). 
For example, 

Icont -c Iibe.icn 

produces the ucode files libe.ul and Iibe.u2. The ucode files can 
be incorporated in another program with the new link directive, 
which has the form 

link Iibe 

The argument of link is, in general, a list of identifiers or 
string literals that specify the names of files to be linked 
(without the .ul or .u2). Thus, when running under UNIX*, 

I ink Iibe, "/usr/icon/iIib/collate" 

specifies the linking of libe in the current directory and col¬ 
late in /usr/icon/iIib. Syntax appropriate to VMS should be used 
when running under that system. 

♦UNIX is a trademark of AT&T Bell Laboratories. 


- 1 - 


The environment variable IPATH controls the location of files 
specified in link directives. IPATH should be have a value of the 
form p1:p2: ... pn where each pi names a directory. Each direc¬ 
tory is searched in turn to locate files named in link direc¬ 
tives. The default value of IPATH is that is, the current 

di rectory. 

2.2 Installation Options 

When an Icon system is installed, various configuration 
options are specified [2], The value of the keyword &options is a 
string that contains the command line arguments that were used to 
configure Icon. 


3. Optional Extensions 

There are two extension options: sets (-sets in &options), and 
a collection of experimental features (-xpx in &options). 

3.1 Sets 

Sets are unordered col lections of values and have the proper¬ 
ties normally associated with sets in the mathematical sense. 

The function 

set(a) 

creates a set that contains the distinct elements of the list a. 
For example, 
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set(["obc",3]) 

creates o set with two members, abc and 3. Note thot 

set(H) 

creates an empty set. Sets, like other data aggregates in Icon, 
need not be homogeneous — a set may contain members of different 
types. 


Sets, like other Icon data aggregates, are represented by 
pointers to the actual data. Sets can be members of sets, as in 


si 

s2 


:* set 
:* set 



in which s2 contains two members, one of which is a set of three 
members and the other of which is an empty list. 

Any specific value can occur only once in a set. For example, 

set([1,2,3,3,1]) 


- 2 - 


creates a set with the three members 1, 2, and 3. Set membership 
is determined the same way the equivalence of values is deter¬ 
mined in the operation 

x —* y 

For example, 

setan.m) 

creates a set that contains two distinct empty lists. 

The functions and operations of Icon that apply to other data 
aggregates apply to sets as well. For example, if s is a set, 

*s 

is the size of s (the number of members in it). Similarly, 
type(s) 

produces the string set and 

s :» set(["abc",3]) 
wr i te(image(s)) 

writes set(2). Note that the string images of sets are in the 
same style as for other aggregates, with the size enclosed in 
parentheses. 

The operation 

Is ' 

generates the members of s, but in no predictable order. Simi¬ 
larly, 


?s 

produces a randomly selected member of s. These operations pro¬ 
duce values, not variables — it is not possible to assign a 
value to Is or ?s. 

The function 

copy(s) 


(continued) 
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produces a new set, distinct from s, but which contains the same 
members as s. The copy is made In the same fashion as the copy of 
a list — the members themselves are not copied. 

The function 


sort(s) 

produces a list containing the members of s in sorted order. 

Sets themselves occur after tables but before records in the 
sorting order. 

The customary set operations are provided. The function 
member(s,x) 

succeeds and returns the value of x if x is a member of s, but 
fails otherwise. Note that 

member(s1,member(s2,x)) 

succeeds if x Is a member of both si and s2. 

The function 

Insert(s,x) 

inserts x into the set s and returns the value of s (it is simi¬ 
lar to put(a,x) in form). Note that 

i nsert(s,s) 

adds s as an member of itself. 

The function 

delete(s.x) 

deletes the member x from the set s and returns the value of s. 

The functions insert(s.x) and delete(s.x) always succeed, 
whether or not x is in s. This allows their use in loops in which 
failure may occur for other reasons. For example, 

s :« set([]) 

while insert(s,read()) 

builds a set that consists of the (distinct) lines from the stan¬ 
dard input file. 

The operations 

si ++ s2 
si ** s2 
si — s2 

create the union, intersection, and difference of si and s2, 
respectively. In each case, the result is a new set. 

The use of these operations on csets is unchanged. There is no 


- 4 - 


automatic type conversion between csets and sets; the result of 
the operation depends on the types of the arguments. For example, 

'aeiou* ++ 'abcde* 

produces the cset abcdeiou, while 

set([1,2,3]) ++ set([2,3,4]) 
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produces a set that contains 1, 2, 3, and 4. On the other hand, 
set([1,2,3]) +4 4 

results in Run-time Error 119 (set expected). 

Examp Ies 
Word Counting: 

The following program lists* in alphabetical order, all the 
different words that occur in the standard input file: 

procedure main() 

letter :* fclcase ++ &ucase 

words :■ set([]) 

while text :■ read() do 

text ? while tab(upto(Ietter)) do 
insert(wCrds,tab(many(letter))) 
every write(I sort(words)) 
end 


The Sieve of Eratosthenes: 

The follow program produces prime numbers, using the classical 
"Sieve of Eratosthenes": 

procedure main(a) 
local limit, s, i 

limit := a[l] | 5000 # limit to 5000 if not specified 

s set([J) 

every insertfs.l to limit) 
every member(s,i :* 2 to limit) do 
every delete(s,i + i to limit by i) 
primes :* sort(s) 

write("There are ",*primes," primes in the first ", limit," integers.") 

write("The primes are:") 

every write(right(1primes,* Iimit + 1)) 

end 


5 - 


4. Expermental Features 
4.1 PDCO Invocation Syntax 

The experimental features include the procedure invocation 
syntax that is used for programmer-defined control operations 
[3]. In this syntax, when braces are used in place of 
parentheses to enclose an argument list, the arguments are passed 
as a list of co-expressions. That is, 

pjexprl, expr2, ..., exprnj 

is equivalent to 

p([create exprl, create expr2.create exprn]) 

Note that 

pH 

is equivalent to 

p(U) 


4.2 Invocation Via String Nome 


[continued) 
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The experimental features allow a string-valued expression 
that corresponds to the name of a procedure or operation to be 
used in place of the procedure or operation in an invocation 
expression. For example, 

"image"(x) 

produces the same call as 
image(x) 


and 


"-■•(i.j) 

is equivalent to 


• - j 


In the case of operations, the number of arguments determines 
the operation. Thus 

Is equivalent to 


-i 

Since to-by is an operation, despite its reserved-word syntax, it 
is included in this facility with the string name ... . Thus 

"..."( 1 , 10 , 2 ) 

is equivalent to 

1 to 10 by 2 

Similarly, range specifications are represented by so that 

i.J) 

is equivalent to 
s[i:j] 


Defaults are not provided for omitted or null-valued arguments 
In this facility. Consequently, 

"..."( 1 , 10 ) 

results In a run-time error when it is evaluated. 

The subscripting operation also is available with the string 
name []. Thus 

"[]"(&lcase,3) 

produces c. 

String names are available for the operations in Icon, but not 
for control structures. Thus 

"|"(expr1,expr2) 

is erroneous. Note that string scanning is a control structure. 
In addition, conjunction is not available via string invocation, 
since no operation is actually performed. 

Field references, of the form 

expr . fieldname 
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are not operations in the ordinary sense and are not available 
via string invocation. 

String names for procedures are available through global iden¬ 
tifiers. Note that the names of functions, such as image, are 
global identifiers. Similarly, any procedure-valued global iden¬ 
tifier may be used as the string name of a procedure. Thus in 


- 7 - 


global q 

procedure main() 
q P 
"q"("hi") 

end 

procedure p(s) 
wr i te(s) 

end 

the procedure p is invoked via the global identifier q. 

4.3 Conversion to Procedure 

The experimental features include the function proc(x,i), 
which converts x to a procedure, if possible. If x is 
procedure-valued, its value is returned unchanged. If the value 
of x is a string that corresponds to the name of a procedure as 
described in the preceding section, the corresponding procedure 
value is returned. The value of i is used to distinguish between 
unary and binary operators. For example, proc("*",2) produces 
the exponentiation operator, while proc("*",1) produces the co¬ 
expression refresh operator. If x cannot be converted to a pro¬ 
cedure, proc(x,l) fails. 

4.4 Integer Sequences 

To facilitate the generation of integer sequences that have no 
limit, the experimental features include the function seq(i,j). 
This function has the result sequence ji, i + j, i+2j, ... }. Omit¬ 
ted or null values for i and j default to 1. Thus the result 
sequence for seq() is {1, 2, 3, ... }. 
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HELLO.ICN 

"An ICON Tutorial," by Ralph E. Griswold and Madge T. 
Griswold, October 1986, page 167. 


procedure maln() 

wr I te("heI Io worId") 

end 


ICONREAD.ME 

"An ICON Tutorial," by Ralph E. Griswold and Madge T. 
Griswold, October 1986, page 167. 


Version 5.9 of Icon for MS-DOS 


This diskette contains executable binary files for Version 5.9 
of Icon running under MS-DOS. This implementation should run on 
an IBM PC, XT, AT or other 8086/88/186/286 family computer. IBM 
PC hardware equivalence is not required; only DOS compatibility 
is needed: PC- or MS-DOS Version 2.0 or above. It is a small 
memory model implementation and requires 192 KB of memory during 
execution. An 8087 will be used if it is present. 

This implementation was done by Cheyenne Wills of Mechan- 
icsburg, Pennsylvania. He has placed it in the public domain to 
make it as widely available as possible. He also provided the 
technical information contained in this document. 

This material is being distributed by the University of 
Arizona as a service to the computing community. It makes no war¬ 
ranties of any kind as to the correctness or suitability of this 
material for any application. 

This diskette can be copied and used freely, provided the 
material on it is not modified and that appropriate credit is 
given where applicable. Persons who obtain a copy of this 
diskette from a secondary source are encouraged to register their 
copy by sending a completed copy of the registration form on this 
diskette (REGIS.FRM) to: 

Icon Project 

Department of Computer Science 
The University of Arizona 
Tucson, AZ 85721 

Persons who register their copies will receive the Icon 
Newsletter, which is published aperiodically, free of charge and 
will be notified of corrections, new releases, and so forth. 
Persons who receive MS-DOS Icon directly from the University of 
Arizona are automatically registered and need not submit the 
registration form. 

Documentation 

Version 5 of the Icon programming language is described in the 
foI lowing book: 
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The Icon Programming Language, Ralph E. Griswold and Madge 
T. Griswold, Prentice-Hall, Inc., Englewood Cliffs, New 
Jersey. 1983. ISBN 0-13-449777-5. 

A brief overview of Icon is contained in the file OVERVIEW.DOC on 
this diskette. Features that have been added to Version 5 of 
Icon since the book was written are described in the file 


- 1 - 


EXTEN.DOC. Printed copies of these documents are available on 
request from the Icon Project at the address listed above. 

Installing MS-DOS Icon 


The four executable binary files need to run Icon are: 


ICONT.EXE 

ITRAN.EXE 

ILINK.EXE 

ICONX.EXE 


command processor 
transIator 
I inker 
interpreter 


These files can be copied to any location that is accessible via 
the current PATH setting. 

Running MS-DOS Icon 

Files containing Icon programs must have the extension .icn. 
Such files should be plain text files (without line numbers or 
other extraneous information). An Icon program in the file 
prog.icn is translated by 

icont prog.icn 

The result is a file with the name prog (with the extension 
removed). This file can be run by 

iconx prog 

Alternatively, the program can be automatically run after trans¬ 
lation by 

icont prog.icn -x 

In this case the file prog also is left and can be run subse¬ 
quent ly using iconx. 

More Information about running Icon is contained in RUN.DOC. 
Testing MS-DOS Icon 

There are a few programs on the distribution diskette that may 
be used for testing Icon: 

hello.icn This program prints the version, installation 
options, time, and date. Run this test as 

icont he I Io.icn -x 


cross.icn This program prints all the ways that two words 
intersect in a common character. The file 
cross.dat contains typical data. Run this test 

as 


2 - 


icont cross.Icn -x ccross.dat 


( continued) 
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meander.fen This program prints the "meandering strings" 
that contain all subsequences of a specified 
length from a given set of characters. Run this 
test as 


Icont meander.Icn -x <meander.dat 


roman.Icn This program converts Arabic numerals from 1 

through 3999 to Roman numerals. Run this test as 

Icont roman.Icn -x 

and provide some Arabic numbers from the con¬ 
sole. 

wordcnt.icn This program tabulates the number of occurrences 
of each word from the input file. Run this test 
as 

icont wordcnt.icn -x <fI Ie 

where file contains some text of interest. Cau¬ 
tion: the tabulation is kept in memory. Do not 
try to process a large file. 

Features of MS-DOS Icon 

MS-DOS Icon supports all the features of Version 5.9 of Icon, 
including sets and the experimental features described in 
EXTEN.DOC, with the following exceptions and additions: 

+ Pipes are not supported. A file cannot be opened with 
the "p" option. 

+ There is two new options for open: "t" and "u". "t" Indi¬ 
cates that the file is to be translated into UNIX format. 
All carriage-return/line-feed sequences are translated 
into newline sequences on both input and output, "t" is 
the default, "u" indicates that the file is to be 
untranslated. Examples are: 

untranfile :■ open("test.fiI","ru"); 
tranflle :* open("test.new","wt"); 


+ The IPATH environment string, as described in EXTEN.DOC 
and RUN.DOC, is supported. The separator between paths 
is the semicolon. The current directory is always 
searched. For example, 


- 3 - 


SET IPATH*A:\;A:\ICON\LIB 

searches the current directory, then root directory on 
drive A, and finally the directory A:\ICON\LIB. 

+ Path specifications can be entered using either a / or a 
\ . Examples are: 

A:\ICON\TEST.ICN 
A:/ICON/TEST.ICN 


+ The following MS-DOS device names can be used as 
fiIenames: 

AUX Refers to an auxiliary device. 

CON Refers to the console. 

PRN Refers to the printer device. 

NUL Specifies a "null" file. Giving NUL as a filename means 
that no file is created. 
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These special names remain associated with the devices 
listed above, even if device designations or filename 
extensions are added to them. For example, A-.CON.XXX 
refers to the console and is not the name of a disk file. 

+ Trace output is sent to STDERR. On MS-DOS STDERR is not 
re-directabIe from the command line. 

Bugs and Limitations 

Since this is a small memory model implementation, the 
amount of data available for a running program is limited. 

This is a new implementation and some problems with it 
are likely to occur. Problems should be reported using the 
trouble report form given in TROUBLE.FRM on the distribution 
d i skette. 

See RUN.DOC for a list of known bugs. 

Future Plans 

A large memory model implementation of Icon under MS-DOS 
is underway. 

Material from the Icon program library is being adapted 
to MS-DOS and will be distributed separately when it is 
ready. 


Ralph E. Griswold 
Department of Computer Science 
The University of Arizona 

December 13, 1985 


MEANDER.DAT 

"An ICON Tutorial," by Ralph E. Griswold and Madge T. 
Griswold, October 1986, page 167. 


abc :2 
1234:2 
ABC: 4 


MEANDER.ICN 

"An ICON Tutorial," by Ralph E. Griswold and Madge T. 
Griswold, October 1986, page 167. 


# MEANDERING STRINGS 


# This main procedure accepts specifications for meandering strings 

# from standard input with the alphabet separated from the length by 

# a colon. 

procedure main() 

local line, alpha, n 
while line :■ read() do { 

line ? if alpha :■ tab(upto(*:’)) then j 
move(1) 

if n :« integer(tab(0)) then write(meander(aIpha,n)) 
else write("erroneous Input") 

else wrIte("erroneous Input") 

end 

(continued) 


BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 53 







October 


procedure meander(aIpha,n) 
local result, t, I, c, k 
I :■ k :* *alpha 
t :• n-1 

result :■ rep I(a Ipha[1],t) 
while c :■ alpha[i ] do { 

If flnd(resuIt[-t:0] || c,result) 
then I 1 

else {result ||:■ c; I kj 

I 

return result 

end 


REGIS.FRM 

"An ICON Tutorial," by Ralph E. Griswold and Madge T. 
Griswold, October 1986, page 167. 


MS-DOS Icon Version 5.9 (SMM) Registration Form 


Note : Persons who receive MS-DOS Icon directly from the Univer¬ 
sity of Arizona are automatically registered and should not 
return this form. 


Please register my copy of MS-DOS Icon Version 5.9 (SMM) and put 
me on the mailing list for the Icon Newsletter. 


name 


address 


teIephone 


electronic mail address 


computers 


operating systems 


Send this form to: 

Icon Project 

Department of Computer Science 
The University of Arizona 
Tucson, AZ 85721 


Decemeber 13, 1985 
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ROMAN.ICN 


"An ICON Tutorial," by Ralph E. Griswold and Madge T. 

Griswold, October 1986, page 167. 


# 

# ROMAN NUMERALS 

# 


# This program takes Arabic numerals from standard input and 

# the corresponding Roman numerals to standard outout. 

writes 

procedure main() 
local n 

while n := read() do 

write(roman(n) | "cannot convert") 

end 


procedure roman(n) 

local arabic, result 
static equiv 

initial equiv ["","I","II","III","IV","V","VI","VII","VIII","IX"] 

integer(n) >0 | fail 

result :« "" 

every arabic :* In do 

result :« map(resuIt,"IVXLCDM","XLCDM**") || equiv[arabic+1] 
if find(,resu 11) then fail else return result 

end 

RUN.DOC 


"An ICON Tutorial," by Ralph E. Griswold and Madge T. 

Griswold, October 1986, page 167. 



The Translation and Execution of Icon Programs under MS-DOS 


The program icont is a command processor for Version 5.9 of 
the Icon programming language. This implementation of Icon runs 
under MS-DOS Version 2.0 or higher on computers with 
8086/88/186/286-family processors, IBM hardware equivalence is 
not necessary. It is a small memory model implementation and 
requires 192 KB of memory. 

icont produces a file suitable for interpretation by the Icon 
interpreter. The Icon translator is run in the form 

icont [ option ... ] file ... [-x] [arg ... ] 

Translation consists of two phases: translation and linking. 
During translation, each Icon source file is translated into an 
intermediate language; during linking, the intermediate language 
files are combined and a single output file is produced. The 
output file from the linker is referred to as an interpretab Ie 
file. Unless the -o option is specified, the name of the result¬ 
ing interpretable file is formed by deleting the suffix of the 
first input file named on the command line. If the -x option is 
used, the file is automatically executed by the interpreter and 
any arguments following the -x are passed as execution arguments 
to the Icon program itself. 

Files whose names end In .icn are assumed to be Icon source 
programs. Such flies should be plain text files (without line 
numbers or other extraneous information). Source programs are 
translated, and the intermediate code is left in two files of the 
same name with .ul and .u2 substituted for .icn. The intermedi¬ 
ate code files normally are deleted when compilation has fin¬ 
ished. Files whose names end In .ul or .u2 are assumed to be 


( continued ) 
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Intermediate code files from a previous translation (only the .ul 
file should be named — the .u2 file is assumed); these files are 
included in the linking phase after any .Icn files have been 
translated. A .ul or .u2 file that is explicitly named is not 
deleted. Icon source programs may be read from standard Input. 
The argument - signifies the use of standard input as a source 
file. In this case, the Intermediate code is placed in stdin.ul 
and stdln.u2 and the interpretable file is stdln. 

The following options are recognized by icont. 

-c Suppress the linking phase. The intermediate code 

files are not deIeted. 

-o output Name the interpretable file output. 

-s Suppress any informative messages from the translator 

and linker. Normally, both Informative messages and 
error messages are sent to standard error output. 

- 1 - 


-t Arrange for &trace to have an initial value of -1 when 

the program Is executed. Normally, &trace has an ini¬ 
tial value of 0. 

-u Issue warning messages for undeclared identifiers in 

the program. The warnings are issued during the link¬ 
ing phase. 

Icon has a number of memory regions related to the translation 
of programs. These regions are large enough for most programs, 
but their size can be changed, if necessary, by the -S option, 
which has the form -S[cfgiIrstCL] n, where the letter following 
the S specifies the region and n is the number of storage units 
to allocate for the region. The regions are: 

c constant table 

f field tab Ie 

g global symbol table 

I identifier table 

I local symbol table 

r field table for record lists 

s string space 

t tree space 

C code buffer 

L labels 

The environment variable IPATH controls the location of files 
specified in link directives. IPATH should have a value of the 
form p1:p2: ... : pn where the pi name directories. Each direc¬ 
tory is searched in turn to locate files named in link direc¬ 
tives. The default value for IPATH is . , that is, the current 
d i rectory. 

The interpretable file produced by the Icon linker is run by 
the program iconx. For example, the command 

1cont he I Io.Icn 

produces a file named hello that can be run by the command 
iconx hello 


The phases also can be executed separately. For example, 
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itran hello.icn 
Mink he I I o. u 1 
iconx hello 


is equivalent to 


icont he I Io.icn -x 


Arguments can be passed to the Icon program by following the 
program name with the arguments. Any such arguments are passed 
to the main procedure as a list of strings. 

When an Icon program is executed, a number of environment 
strings are examined to determine certain execution parameters. 
The values assigned to these strings should be numbers. The 
environment strings that affect execution and the interpretations 
of their values are as follows: 


TRACE Initialize the value of fctrace. If this variable has a 
value, it overrides the translation-time -t option. 

NBUFS The number of i/o buffers to use for files. When a 

file is opened, it is assigned an i/o buffer if one is 
available and the file is not a console. If no buffer 
is available, the file is not buffered. fcinput, &out- 
put, and fcerrout are buffered if buffers are available. 
The default number is 5. 


NOERRBUF If set, fcerrout is not buffered. 

STRSI2E The initial size of the string space, in bytes. The 

string space grows if necessary, but it never shrinks. 
The default value is 10,240. 

HEAPSIZE The initial size of the heap, in bytes. The heap grows 
if necessary, but it never shrinks. The default value 
is 10,240. 

NSTACKS The number of stacks initially available for co¬ 
expressions. More are automatically allocated if 
needed. The default value is 2. 


STKSIZE The size of each co-expression stack, in words. The 
default value is 1000. 


Files 


The following files are needed to translate and run Icon pro¬ 
grams : 


icont.exe 
itran.exe 
iIink.exe 
iconx.exe 


command processor 
t ransIator 
linker 
interpreter 


s 


References 

An Overview of the Icon Programming Language, Ralph E. Griswold, 
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tember 1985. 

The Icon Programming Language, Ralph E. Griswold and Madge T. 
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Bugs and Deficiencies 

Downward compatibility of InterpretobIe files will not be 
maintained in subsequent releases of Icon. No checks are per¬ 
formed to determine if the interpretable file and the Interpreter 
are compatible. Peculiar program behavior is the only Indication 
of such Incompatibility. 

Interpretable files do not stand alone; the Icon Interpreter 
must be present on the system. This implies that the interpreter 
is of the same version of Icon as the translator that produced 
the interpretable file. 

Because of the way that co-expressions are implemented, there 
is a possibility that programs in which they are used may mal¬ 
function mysteriously. 

Integer overflow on multiplication is not detected. 

The -x option for icont requires 256 KB of memory to be effec¬ 
tive. Nonetheless, an interpretabIe file is produced and may be 
run with iconx. 

If garbage collection fails, Iconx may abort with an Inap¬ 
propriate message. 

Stack overflow is not detected immediately and may generate 
odd messages. 

If the last line of a source program does not have the usual 
end-of-line termination, the translator fails with the message 
"line 0; invalid character 1 '. 

Ralph E. Griswold 
Department of Computer Science 
The University of Arizona 

December 13, 1985 


SYSENV.ASM 

"CP/M Hall of Fame," by Brock N. Meeks, October 1986, page 219. 


* SYSTEM SEGMENT: SYSTEM.ENV 

* AUTHOR: RICHARD CONN 

; PROGRAM: SYSENV.ASM 
; AUTHOR: Richard Conn 
; Version: 1.0 
; Date: 22 Feb 84 
; Previous Versions: None 


SYSENV is the definition for my ZCPR3 environment, and it is loaded 
as my ZCPR3 Environment Descriptor by Z3LDR. SYSENV is named to SYS.ENV 
after assembly to permit this. 


Environment Definitions 

MACLIB Z3BASE 
MACLIB SYSENV 


Include Environment Descriptor 

org 100H ; origin 

jmp 0 ; leading JMP 

SYSENV 

end 
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Z-HELPER.EI 

"CP/M Hall of Fame," by Brock N. Meeks, October 1986, page 219. 


Z SYSTEM GOOD-NEIGHBOR HELPER ROSTER 


Mark Kolod 
POB 68 

Glenview, IL 60025 
312/291-1586 

Brian Leyton - Morrow 
12613 KiI I ion Street 
North Hollywood, CA 91607 
818/766-3307 


Neal Koss 
3440 Lomita Blvd. 
Torrance, CA 90505 
213/326-8770 

Joe Wright - a I I 
711 Chatsworth Place 
San Jose, CA 95128 
408/297-5583 


Kevin McDonald - Apple 
300 Union Avenue #1 
CampbeI I, CA 95008 
408/371-5037 


Joe S. Vogler 
3327 Springridge Circle 
Colorado Springs, CO 80906 
303/576-3490 


Doug Thom - AppIe/CompuPro/Ampro 
1405 Graywood Drive 
San Jose, CA 95129 
408/253-1306 

Isaac Salzman - Xerox 820-11 
5667 Corteen Place 
No. Hoilywood, CA 91706 
818/761-7874 

Charles Sanborn - all 
12702 Campos Drive 
Houston, TX 77065 


Chuck Livingston - Vector Graphics 
412 Tierra Rejada Road 
Simi Valley, CA 93065 
805/522-7322 or 584-3484 

Steve Kapplin - Osborne/CCS S-100 
11711 Moffat Avenue 
Tampa, FL 33617 

813/985-5611 (home) 813/974-2081 (work) 
Francis Rlesz 

3228 South Broad Street Apt. 5 
Trenton, NJ 08610 


John Smith - Kaypro 
4628 Brookhill Drive North 
Manlius, NY 13104 
315/682-8185 

Steven Hirsch - Apple CP/M 
124 Intervale Ave. 

Bur Iington, VT 05401 
802/658-4793 

Alan D. Wilcox - CompuPro 
60 South 8th Street 
Lewisburg, PA 17837 
717/523-0777 before 8pm EST 


Thomas A. Flemer - Morrow 
1730 Medallion Loop N.W. 
Olympia, WA 98502 
206/866-9787 

Arthur Welsh - Osborne 
801 Airport Hts. #387 
Anchorage, AK 99508 
907/274-8044 

Jay P. Sage 
1435 Centre Street 
Newton Centre, MA 02159 
617/965-3552 


£Good-neighbor Helper Roster (over) 

9 January 1985 
Page 2 


Al Dunsmulr - CompuPro 
1840 Victoria Park Ave. Apt. 1005 
Scarbourough, Ontario 
MIR 1S9 CANADA 


RoI and Eriksson - a I I 
Arbetshusgatan 58 A 
802 24 Gaevle SWEDEN 
Int+46 - "26" 128353 


Robert Kuhmann - a I I 
Le PavlI Ion, Belle Etoile 
par St. Martin de la Brasque 
84760 FRANCE 
011/33 90-77-61-36 


Echelon, Inc. 

101 First Street 
Los Altos, CA 94022 
Telephone: 415/948-3820 

(continued) 
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Z3BAS.LIB 

“CP/M Hall of Fama," by Brock N. Meeks, October 1986, page 219. 


Z3BASE - Maximum Configuration 
Offset: 3D80H 

4c4c4c4c4c4»4c4c4c4c4«4<4«4t4*4«4«4c4«4c4«4c4«4c4«4c4c4c4t4c4c4c4c4^4c4c4c4c4«4«4«4t4«4c4«4c4«4c4t4t4c4c4c4c********* 

Z3BASE.LIB — Base Addresses for ZCPR3 System 
for the Kaypro 10 
by John C. Smith 


Rev 

Rev 


These 
Segments: 


* 

* 

♦ 

* 

* 

♦ 

♦ 

♦ 

* 

* 

* 

* 

* 

* 

* 

* 

* 

* 

♦ 

♦ 

* 

* 

# 

* 

♦ 

* 

♦ 

* 

* Memory Map of System: 

* 


7/23/84 

6/09/85 for the 1983 
Kaypro II and IV 
by Steven M. Cohen 


(non-video enabled) 


addresses are used by the following System 


Segment 

Function 

BDOSZ 

CBIOSZ 

ZCPR3 

4..ENV 

4C.FCP 

*.NDR 

*.RCP 

Customized BOOS with DEL key fix 
Customized BIOS 

ZCPR3 Command Processor 

All Environment Descriptors 

All Flow Command Packages 

All Named Directory Definition Files 
All Resident Command Packages 

Segment 
*. FCP 

4..ENV 

*.NDR 

PUTOVL Address Load Offset 

0C00 iB00 

0E00 0000 

1000 0F00 


4> 

4c 

Address 

Range 

Size 

4c 

0 

- 

FF 

256 b 

4c 

3E 



1 b 

4c 

40 

- 

4A 

11 b 

4c 

100 

- 

CBFF 

-51 K 

4c 

CC00 

- 

D3FF 

2 K 

4c 

D400 

- 

E1FF 

3.5K 

4c 

E200 

- 

E5FF 

-1 K 

4* 

E600 

- 

EDFF 

2 K 

4c 

EE00 

- 

F0FF 

384 b 

4c 




(Inc 1 

4c 




k 10 

4c 




for 

4c 

F100 

- 

F2FF 

0.5K 

4c 

4c 

F300 

- 

F3FF 

256 b 

4c 





4c 

F400 

- 

F47F 

128 b 

4c 

F480 

- 

F4CF 

80 b 


Function 


Buffers except 
Path 


Standard CP/M 
Wheel Byte 
for ZCPR3 External 
TPA 

ZCPR3 Command Processor 
BDOSZ 

CBIOSZ with Buffers 
Resident Command Package 
Hard Disk Errors & Graphics 
uded for compatibility with 
and 484 versions. Free space 
the 483 

Flow Command Package 
Environment Descriptors 
Bytes 00H-7FH: Z3 Parameters 
Bytes 80H-FFH: Z3 Terminal Cap 
ZCPR3 She I I Stack 
ZCPR3 Message Buffers 


* 

* 

* 

* 

4c 

♦ 

* 

* 

♦ 

* 

* 

♦ 

♦ 

♦ 

* 

* 

* 

* 

* 

* 

* 

* 

♦ 

* 

♦ 

* 

♦ 

* 

* 

♦ 

* 

* 

* 

* 

* 

4c 

4c 

4c 

4* 

4c 

4c 

4c 

4c 

4t 

4c 

4c 

4c 


Byte 

Byte 

Byte 

Byte 


Error 
IF (8 


IF 


00B 
01B 
10B 

Bytes 4&5 
Byte 6 
Byte 7 


Flag (Z/NZ) 
LeveIs) 

Active (8 Levels) 
Z3 Cmd Status 

- Normal 

- Shell 

- Error 
Error Address 


if 


00B 
01B 
10B 

Byte 8: ZEX 
Bytes 9-10: 

Char 


4c 
* 
4c 
4c 
4c 
* 
4c 

- . 10B 4. 

Program Error Code 4 c 

ZEX Message Byte 4 c 

- Normal 4c 

- Z3 Prompt 4c 

- Suspend Intercept 4c 
Running Flag (0*No) 4< 
Address of Next 4c 

for ZEX to Return 4c 
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* 



Bytes 11-12: Address of First 

* 

* 



Char in ZEX Memory- 

* 

* 



Based File Buffer 

* 

* 



Byte 13: SH Control Byte 

* 

* 



Bit 0: Enable SHCMT 

* 

* 



Bit 1: Enable SHECHO 

* 

* 



Bit 7: Enab1e She 11 

* 

* 



Entry Wait 

* 

* 



Bytes 14-15: Shel1 Scratch 

* 

* 



Bytes 10H-2FH: Error Cmd 

* 

* 



Bytes 30H-39H: Registers 

* 

* 



Bytes 3AH-3FH: Reserved 

* 

* 



Bytes 40H-4FH: User-Defined 

* 

* 

F4D0 

- F4FF 

48 b ZCPR3 External FCB 

* 

* 

F500 

- F5FF 

256 b Memory-Based Named Directory 

* 

♦ 

F600 

- F6CF 

208 b Multiple Command Line Buffer 

* 

* 

F6D0 

- F6FF 

48 b ZCPR3 External Stack 

* 

* 

F700 

- FBFF 

1.25K free space, ideal for Ram 

* 

* 



disk code, etc. Included for 

* 

* 



compatibility with K10 and 484 

* 

♦ 



versions 

* 

* 

FC00 

- FFFF 

1 K BIOS buffers (disk controller) 

* 

* 

**************************************************************** 

FALSE 

equ 

0 



TRUE 

equ 

NOT FALSE 


Z3REV 

EQU 

31 

; ZCPR3 REV NUMBER 


CBREV 

EQU 

41 

; CBIOSZ REV NUMBER 


MSIZE 

EQU 

58 

; SIZE OF CPM SYSTEM 

• 

BASE 

EQU 

0 



18080 

EQU 

FALSE 



EXPATH 

EQU 

40H 

; EXTERNAL PATH 


EXPATHS 

EQU 

5 

; 5 2-byte Path Elements 





; (PATH SIZE - EXPATHS*2 4 1) 


Z3WHL 

EQU 

3EH 

; WHEEL BYTE ADDRESS 


CCP 

EQU 

0CC00H 

; ZCPR3 COMMAND PROCESSOR 


RCP 

EQU 

0E600H 

; RESIDENT COMMAND PACKAGE 


RCPS 

EQU 

16 

; 16 128-byte Blocks (2K bytes) 


I OP 

EQU 

0 

; REDIRECTABLE I/O PACKAGE 


IOPS 

EQU 

0 

; 12 128-byte Blocks (1.5K bytes) 


FCP 

EQU 

0F100H 

; FLOW COMMAND PACKAGE 


FCPS 

EQU 

4 

; 4 128-byte Blocks (0.5K bytes) 


Z3ENV 

EQU 

0F300H 

; ENVIRONMENT DESCRIPTORS 


Z3ENVS 

EQU 

2 

; SIZE OF ENVIRONMENT DESCRIPTOR IN 128-BYTE BLOCKS 

SHSTK 

EQU 

0F400H 

; ZCPR3 SHELL STACK 


SHSTKS 

EQU 

4 

; NUMBER OF SHSIZE-BYTE SHELL STACK ENTRIES 

SHSIZE 

EQU 

32 

; SIZE OF A SHELL STACK ENTRY 





; (STACK SIZE - SHSTKS * SHSIZE) 


Z3MSG 

EQU 

0F480H 

; ZCPR3 MESSAGE BUFFER 


EXTFCB 

EQU 

0F4D0H 

; ZCPR3 EXTERNAL FCB 


Z3NDIR 

EQU 

0F500H 

; ZCPR3 NAMED DIRECTORY AREA 


Z3NDIRS 

EQU 

14 

; 14 18-byte Named Directory Elements 

permitted 




; (NDIR SIZE - Z3NDIRS*18 + 1 for trailing 0) 

Z3CL 

EQU 

0F600H 

; ZCPR3 COMMAND LINE BUFFER 


Z3CLS 

EQU 

200 

; SIZE OF COMMAND LINE BUFFER 


EXTSTK 

EQU 

0F6D0H 

; ZCPR3 EXTERNAL STACK 



;* END of ZCPR3 BASE EQUATES 


;* 

imtinued) 
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Z3H0R.LBR 

"CP/M Hoi I of Fame," by Brock N. Meeks, October 1986, page 219. 


; Z3H0R - Maximum Configuration 
; Offset: 3D80H 

* 

Z C P R 3 — Z80-Based Command Processor Replacement, Version 3.0 

Copyright (c) 1984 by Rlchord Conn 
Copyright Pending, US Government 
All Rights Reserved 


*** 

* 

* 

* 

* 

* 

* 


Module: Z3H0R 

Author: Richard Conn 

Module Used By: ZCPR3 Version 3.1 

Note: Z3HDR contains the key customization equates for ZCPR3 These 
equates allow the user to select various ZCPR3 options and do an 
extensive amount of tailoring of ZCPR3 to the user’s desires 


;VALUE PROVIDED IN Z3BASE.LIB 


REL 

• 

EQU 

FALSE 

• 

IF 

REL 

CPRLOC 

EQU 

ELSE 

0 

CPRLOC 

EQU 

CCP 


ENDIF 


COMTYP 

MACRO 



DB 

ENDM 

’COM* 

SUBTYP 

MACRO 



OB 

ENOM 

•SUB* 

SUBON 

EQU 

TRUE 

DRVPREFIX 

equ 

COMATT 

equ 

01H 

DIRON 

equ 

FALSE 

LTON 

equ 

FALSE 

GOON 

equ 

TRUE 

ERAON 

equ 

FALSE 

SAVEON 

equ 

TRUE 

RENON 

equ 

FALSE 

GETON 

equ 

TRUE 

JUMPON 

equ 

TRUE 

NOTEON 

equ 

TRUE 

» 

IF 

Z3WHL 

WERA 

equ 

FALSE 

WREN 

equ 

FALSE 

WLT 

equ 

FALSE 

WGO 

equ 

FALSE 

WSAVE 

equ 

FALSE 

WGET 

equ 

FALSE 

WJUMP 

equ 

FALSE 

WDU 

equ 

FALSE 

WHEEL 

equ 

ENDIF 

WERA 0 

NCHARS 

EQU 

4 


TRUE 


DIR COMMAND 

LIST. TYPE COMMANDS 

GO COMMAND 

ERA COMMAND 

SAVE COMMAND 

REN COMMAND 

GET COMMAND 

JUMP COMMAND 

NOTE COMMAND 


0 ;IF 

Make ERA a 
REN " 
L/T “ 
GO M 
SAVE 
GET " 
JUMP 
DU: " 


A WHEEL BYTE ADDRESS IS DEFINED 
Wheel-Oriented Command 


(LIST/TYPE) 


(DU/DIR Change) 


;Z3WHL 


;NUMBER OF CHARS/COMMAND 


CTABLE MACRO 
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IF 

DIRON 



DB 

’DIR * 



DW 

ENDIF 

DIR 

;DIRECTORY DISPLAY COMMAND 

• 

IF 

LTON 



DB 

’LIST* 



DW 

LIST 

;LIST FILE ON PRINTER COMMAND 


DB 

’TYPE’ 



DW 

ENDIF 

TYPE 

;TYPE FILE ON CONSOLE COMMAND 

• 

IF 

GOON 



DB 

’GO ’ 



DW 

ENDIF 

GO 

;EXECUTE CURRENT TPA COMMAND 

• 

IF 

ERAON 



DB 

'ERA * 



DW 

ENDIF 

ERA 

;ERASE FILES COMMAND 

t 

IF 

SAVEON 



DB 

’SAVE* 



DW 

ENDIF 

SAVE 

;SAVE TPA COMMAND 

• 

IF 

RENON 



DB 

’REN * 



DW 

REN 

;RENAME FILES COMMAND 


ENDIF 



• 

IF 

GETON 



DB 

’GET * 



DW 

ENDIF 

GET 

;LOAD FILE INTO TPA COMMAND 

• 

IF 

JUMPON 



DB 

’JUMP* 



DW 

JUMP 

;JUMP TO ANY MEMORY LOCATION COMMAND 


ENDIF 



1 

IF 

NOTEON 



DB 

’NOTE* 



DW 

ENDIF 

NOTE 

;NOTE - NULL COMMAND (NOP) 


ENDM 



WIDE 

EQU 

FALSE 


FENCE 

EQU 

•r 


SYSFLG 

EQU 

*A* 


SOFLG 

EQU 

*S* 


ERAOK 

equ 

FALSE 


ERAV 

equ 

FALSE 


ERDFLG 

equ 

*V* 


PGDFLT 

EQU 

TRUE 


PGDFLG 

EQU 

*P* 


NLINES 

EQU 

24 


SECTFLG 

; EQU 

*S* 


» 

IF 

EXPATH NE 0 

•.External Path Selected 

PATH 

equ 

EXPATH 

;External ZCPR3 PATH at CBIOS Buffer Area 


ELSE 


;Internal Path Selected 


[continued) 
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IPATH MACRO 

db , A'- , ®’,’$’ ;Oisk A, Current User 

db •A’-’S-.e ;Disk A, User 0 

** 0 :End of Poth — MUST be here 


END IF 

MINPATH EQU TRUE 
SCANCUR EQU TRUE 
INCLDU equ TRUE 
ACCPTOU EQU TRUE 
NDINCP EQU TRUE 
INCLNDR EQU TRUE 
ACCPTND EQU TRUE 
DUFIRST EQU TRUE 


PWCHECK EQU FALSE 



IF 

Z3CL NE 

0 


MULTCMD 

equ 

TRUE 




ELSE 




MULTCMD 

equ 

FALSE 




ENDIF 




CMDSEP 

equ 

* • * * 
l 



CMDRUN 

equ 

TRUE 

; Enoble the Foci 1ity 


if 

CMDRUN 



ROOTONLY 

equ 

TRUE 

; TRUE if look at Root Only for Extended 

CMDFCB 

MACRO 



; Command Processor, FALSE if look along 
; poth a 


db 

0 




db 

'CMDRUN 

• 

;Nome of Program 


db 

ENDM 

'COM* 


;F11e Type 


endl f 

;CMDRUN 



IFON 

EQU 

TRUE 



MAXUSR 

MAXDISK 

EQU 

15 


;MAXIMUM USER NUMBER ACCESSABLE 

EQU 

4 


MAXIMUM NUMBER OF DISKS ACCESSABLE 

SUPRES 

EQU 

FALSE 


;SUPPRESSES USER # REPORT FOR USER 0 

SPRMPT 

CPRMPT 

EQU 

EQU 

*$’ 


;CPR PROMPT INDICATING SUBMIT COMMAND 



;CPR PROMPT INDICATING USER COMMAND 

NUMBASE 

EQU 

*H* 


;CHAR USED TO SWITCH FROM DEFAULT NUMBER BaSE 

CURIND 

EQU 



;SYMBOL FOR CURRENT DISK OR USER 

COMMENT 

EQU 

* • * 

» 


;LINES BEGINNING WITH THIS CHAR ARE COMMENTS 

; END OF 

• 

ZCPR3 

CUSTOMIZATION 

SECTION 

SYSRCP.ASM 

"CP/M Ho 11 of Fame," by Brock 

N. Meeks, October 1986, page 219. 


* SYSTEM SEGMENT: SYS.RCP 

* SYSTEM: ARIES-1 

* CUSTOMIZED BY: RICHARD CONN 
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PROGRAM: 
AUTHOR: 
VERSION: 
DATE: 3 


SYSRCP.ASM 
RICHARD CONN 
1.0 

FEB 84 


* PREVIOUS VERSIONS: NONE 


VERSION 

EQU 

10 



* 

* 

SYSRCP 

is a resident command processor for ZCPR3. As with 

♦all resident 

command processors, 

SYSRCP 

performs the following functions: 

* 

♦ 


1. Assuming that the EXTFCB contains the name of the 

♦ 


command, SYSRCP looks to see if the first character 

♦ 


of the file 

name 

field in the EXTFCB is a question 

♦ 


mark; if so 

, it returns with the Zero Flag Set and 

♦ 


HL pointing 

to the internal routine which prints 

♦ 


its list of 

commands 

♦ 


2. The resident command 

list in SYSRCP is scanned for 

♦ 


the entry contained in the file name field of 

♦ 


EXTFCB; if 

found, 

SYSRCP returns with the Zero Flag 

♦ 


Set and HL 

pointing to the internal routine which 

♦ 


imp 1ements 

the function; if not found, SYSRCP returns 

♦ 

♦ 


with the Zero Flag Reset (NZ) 

♦ 

♦ Globe 

il Library which Defines Addresses 

for SYSRCP 

♦ 

MACLIB 

Z3BASE ; USE BASE 

ADDRESSES 


MACLIB 

SYSRCP ; USE SYSRCP HEADER 

CTRLC 

EQU 




TAB 

EQU 

09H 



LF 

EQU 

0AH 



FF 

EQU 

0CH 



CR 

EQU 

0DH 



CTRLX 

EQU 

■X’-'@’ 



WBOOT 

EQU 

BASE+0000H 


CP/M WARM BOOT ADDRESS 

UDFLAG 

EQU 

BASE+0004H 


USER NUM IN HIGH NYBBLE, DISK IN LOW 

BDOS 

EQU 

BASE+0005H 


BDOS FUNCTION CALL ENTRY PT 

TFCB 

EQU 

BASE+005CH 


DEFAULT FCB BUFFER 

FCB1 

EQU 

TFCB 


1st and 2nd FCBs 

FCB2 

EQU 

TFCB+16 



TBUFF 

EQU 

BASE+0080H 


DEFAULT DISK I/O BUFFER 

TPA 

EQU 

BASE+0100H 


BASE OF TPA 

DIRBUF 

EQU 

BASE+4000H 


DIR BUFFER (MANY ENTRIES PERMITTED) 

PAGCNT 

EQU 

DIRBUF-100H 


PAGE COUNT BUFFER 

OLDFCB 

EQU 

PAGCNT+1 


OLD FCB BUFFER 

CPBLOCKS 

EQU 32 


USE 4K FOR BUFFERING OF COPY 

S-MACRO 


;FIRST TURN OFF THE EXPANSIONS 


MACROS TO PROVIDE Z80 EXTENSIONS 
MACROS INCLUDE: 


; JR 

; JRC 

; JRNC 

; JRZ 

; JRNZ 

; DJNZ 

just as if a 
$e 


- JUMP RELATIVE 

- JUMP RELATIVE IF CARRY 

- JUMP RELATIVE IF NO CARRY 

- JUMP RELATIVE IF ZERO 

- JUMP RELATIVE IF NO ZERO 

- DECREMENT B AND JUMthe library, 
separate .COM file were being run. 


(continued) 
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SVSRCP.LIB 

"CP/M Hall of Foma," by Brock N. Meeks, October 1986, page 219, 


RCPID 

EQU 

’A’ 


CPON 


EQU 

TRUE 

DIRON 


EQU 

FALSE 

SYSFLG 


EQU 

'A 1 

SOFLG 


EQU 

■S' 

SORTNT 


EQU 

TRUE 

WIDE 


EQU TRUE 

FENCE 


EQU 

i • 

ERAON 


EQU TRUE 

LTON 


EQU TRUE 

LISTON 


EQU TRUE 

PGDFLT 


EQU TRUE 

PGDFLG 


EQU 

•P* 

NLINES 


EQU 24 

PEEKON 


EQU TRUE 

POKEON 


EQU TRUE 

PROTON 


EQU TRUE 

RENON 


EQU TRUE 

REGON 


EQU FALSE 

WHLON 


EQU FALSE 

WPASS 

MACRO 




DB 

•SYSTEM 

;8 characters 


ENDM 



WCP 

equ 

FALSE 

Make CP a Whee1-Oriented Command 

WDIR 

equ 

FALSE 

M DIR " " •• •• 

WERA 

equ 

FALSE 

" ERA " M 

WLIST 

equ 

FALSE 

" LIST " " •• •• 

WPEEK 

equ 

FALSE 

" PEEK " M •• 

WPOKE 

equ 

FALSE 

" POKE " " " •• 

WPROT 

equ 

FALSE 

" PROT " " •• i< 

WREG 

equ 

FALSE 

" REG M " " •• 

WREN 

equ 

FALSE 

" REN M " 

WTYPE 

equ 

FALSE 

" TYPE " " •• « 

WHEEL 

set 

WCP OR WDIR OR WERA OR WLIST OR WPEEK OR WPOKF 

WHEEL 

set 

WHEEL OR 

WPROT OR WREG OR WREN OR WTYPE 

NOTEON 

EQU 

FALSE 


ECHOON 

EQU 

TRUE 


ECHOLST 

EQU 

TRUE 



END of SYS.RCP CUSTOMIZATION 


SYSNDR.LIB 

"CP/M Hall of Fame," by Brock N. Meeks, October 1986, page 219. 


DATA FILE: SYSNDR.LIB 
AUTHOR: Richard Conn 
VERSION: 1.0 

DATE: 24 Feb 84 


SYSNDR.LIB defines the structure of 
It also defines a few elements for it and 
an NDR file. 


the memory-based named directory, 
is suitable for enclosure in 


The general structure is: 
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DB Disk,User ; A=1 

DB 'NDIRNAME* ; 8 chars 

DB 'PASSWORD' ; 8 chars 




DB* 0 

def du 

macro 

db 

db 

endm 

?disk,?user 

?disk-’@’ 

?user 

sysndr 

macro 
def du 
db 
db 

'A' ,0 
'BASE 


def du 

db 

db 

'A',15 
' ROOT 

» » 


def du 

db 

db 

'A',16 
’HELP 

» • 


def du 

db 

db 

'B’ ,0 

'SCRATCH ' 

* » 


def du 

db 

db 

'B' .1 
'ASM 

» • 


def du 

db 

db 

'B' ,2 

»c 

• # 


def du 

db 

db 

'B' ,3 

•PASCAL • 

• » 


def du 

db 

db 

'B' .4 
'SCR 

» * 


def du 

db 

db 

'B' ,5 

'BASIC 
» • 


def du 

db 

db 

'B' .7 
'TEXT 

t * 


def du 

db 

db 

'B' .8 
•CAT 

> • 


def du 

db 

db 

'B' .9 
’ DATA 

• • 


def du 

db 

db 

•C' ,0 

’BACKUP * 


db 

endm 

0 


; other entries 
; End of NDR 


; Convert Disk 
; User is OK 


;End of List 


End of SYSNDR.LIB 


{continued) 


BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER 1986 67 








October 


SYSNDR.ASM 

"CP/M Hall of Fame," by Brock N. Meeks, October 1986, page 219. 


PROGRAM: SYSNDR.ASM 
AUTHOR: RICHARD CONN 
VERSION: 1.0 

DATE: 24 FEB 84 


SYSNDR.ASM sets up a memory-based named directory file suitable 
for loading by Z3LDR. It does this by including SYSNDR.LIB. 

MACLIB SYSNDR 

org 100h 

SYSNDR ; Invoke macro 

end 


SYSIOP.ASM 

"CP/M Hall of Fame," by Brock N. Meeks, October 1986, page 219. 


* SYSTEM SEGMENT: SYSTEM.IOP 

* SYSTEM: ARIES-1 

* CUSTOMIZED BY: RICHARD CONN 

* PROGRAM: SYSIOP.ASM 

* AUTHOR: RICHARD CONN 

* VERSION: 1.0 

* DATE: 22 FEB 84 

* PREVIOUS VERSIONS: NONE 

* - Customize Section -* * * * * 

* Customization Performed Throughout Code 

* -End of Customize Section-* 


*************************************+*++*+++++++++++++++++++++++ 
* * 

* SYSIO — Standard Set of Redirectable I/O Drivers * 

* for ZCPR2 configured for Richard Conn's ARIES-1 System * 

* * 

* Feb 2, 1984 * 


* Note on Assembly: * 

* This device driver package is to be assembled by MAC * 

* (because of the macros) and configured into a file of type * 

* 10 by loading it at 100H via DDT or SID/ZSID and saving the * 

* result as a COM file. Care should be taken to ensure that * 

* the package is not larger than the device driver area which * 

* is reserved for it in memory. * 


***************************************************************** 


MACLIB Z3BASE ; Get Addresses 


IOBYTE equ 
INTIOBY equ 


3 ; I/O 

100$1$1$000B 


BYTE 

•.Initial I/O Byte Value 
; LST:*TTY 
; RDR:, PUN:«Clock 
; CON:«CRT 


********************************************** + *****^ j|tj(cj(tj(tj(tj((#j|tj(ti|{# 
* * 

* Disk Serial, MPU Serial, Quad I/O, and Modem Equates * 

* * 
****************************************** + ******* +++ ^ +#j|tj<t34tj , t++j)t# 
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I • Disk Serial — Serial Channel on Disk Controller Board (DCE) 
Baud Rate is set at 19,200 Baud in Hardware (DIP Switches) 
ustat equ djeprom+3F9H ;USART Status Address 

ostat equ 8 -.Output Status Bit (TBE) 

| istat equ 4 ;Input Status Bit (RDA) 

Serial Channel on CCS Z80 MPU Board (DCE) 

20H ;Base address of 8250 on CCS Z80 MPU Board 
mpubase ;Dota I/O Registers 

mpubase jDivisor Latch Low 

mpubase+1 ;Divisor Latch High 

mpubase+1 ;Interrupt EnabIe Register 

mpubase+3 ;Line Control Register 

mpubase+4 -.Peripheral Control Register 

mpubase+5 -.Line Status Register 

mpubase+6 ;Peripheral Status Register 


; MPU Serial — 
mpubase equ 
mpudata equ 
mpudI I equ 
mpudlh equ 
mpuier equ 
mpulcr equ 
mpupcr equ 
mpustat equ 
mpupsr equ 


; MPU Serial 
mpurda equ 
mputbe equ 


RDA and TBE 

1 ; Data Available Bit (RDA) 

20h ; Transmit Buffer Empty Bit (TBE) 


: MPU Serial Baud Rate Values 


bm00050 

equ 

2304 

bm00075 

equ 

1536 

bm00110 

equ 

1047 

bm00134 

equ 

857 

bm00150 

equ 

768 

bm00300 

equ 

384 

bm00600 

equ 

192 

bm01200 

equ 

96 

bm01800 

equ 

64 

bm02000 

equ 

58 

bm02400 

equ 

48 

bm03600 

equ 

32 

bm04800 

equ 

24 

bm07200 

equ 

16 

bm09600 

equ 

12 

bm19200 

equ 

6 

bm38400 

equ 

3 

bm56000 

equ 

2 


50 

75 

110 

134. 

150 

300 

600 

1200 

1800 

2000 

2400 

3600 

4800 

7200 

9600 

19200 

38400 

56000 


Baud 
Baud 
Baud 
5 Baud 
Baud 
Baud 
Baud 
Baud 
Baud 
Baud 
Baud 
Baud 
Baud 
Baud 
Baud 
Baud 
Baud 
Baud 


; MPU Serial Channel Baud Rate 

mpbrate equ bm09600 ; 9600 Baud for TTY 


; Quad I/O Ports 


qbase 

q0data 

q0stat 

qldata 

qlstat 

q2data 

q2stat 

q3data 

q3stat 

q0baud 

qlbaud 

q2baud 

q3baud 

; Quad 

qrda 

qtbe 


equ 

80h ; 

equ 

qbase 

equ 

qbase+1 

equ 

qbase+2 

equ 

qbose+3 

equ 

qbase+4 

equ 

qbase+5 

equ 

qbase+6 

equ 

qbase+7 

equ 

qbase+8 

equ 

qbase+9 

equ 

qbase+10 

equ 

qbase+11 

I/O RDA 

and TBE 

equ 

2 

equ 

1 


Base address of Quad RS-232 I/O Board 
; USART 0 Data Port (DTE) 

; USART 0 Status Port 
; USART 1 Data Port (DTE) 

; USART 1 Status Port 
; USART 2 Data Port (DTE) 

; USART 2 Status Port 
; USART 3 Data Port (DCE) 

; USART 3 Status Port 
; USART 0 Baud Rote Port 
; USART 1 Baud Rate Port 
; USART 2 Baud Rate Port 
; USART 3 Baud Rote Port 


Read Data Available Bit (RDA) 
Transmit Buffer Empty Bit (TBE) 


************************************* 

* Equate Values for PMMI as Modem * 
************************************* 

* Modem Ports (Special — 300 or 600 Baud for PMMI) 

*mods equ 0E0H ; Modem Status Byte 

*modd equ 0E1H ; Modem Data Byte 

* 


* Modem RDA and TBE 

*mrda equ 2 ; Read Data Available Bit (RDA) 

*mtbe equ 1 ; Transmit Buffer Empty Bit (TBE) 

************************************* 


[continued) 
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; Modem Ports set to QUAD I/O Port 2 
mods equ q2stot ; Modem Status Port 

modd equ q2data ; Modem Data Port 


; Modem RDA and TBE 
mrda equ qrda 
mtbe equ qtbe 


; Baud Rate Values 
b00050 equ 0 

b00075 equ 1 

b00110 equ 2 

b00134 equ 3 

b00150 equ 4 

b00300 equ 5 

b00600 equ 6 

b01200 equ 7 

b01800 equ 8 

b02000 equ 9 

b02400 equ 10 

b03600 equ 11 

b04800 equ 12 

b07200 equ 13 

b09600 equ 14 

b19200 equ 15 


50 

Baud 

75 

Baud 

110 

Baud 

134. 

5 Baud 

150 

Baud 

300 

Baud 

600 

Baud 

1200 

Baud 

1800 

Baud 

2000 

Baud 

2400 

Baud 

3600 

Baud 

4800 

Baud 

7200 

Baud 

9600 

Baud 

19200 

Baud 


******************** ******** ***************************++++++*+*+ 
* Baud Rates for Quad I/O Devices * 

*********************************+****************+t„„ m ^^Jl 


q0brate equ b09600 
qlbrate equ b01200 
q2brate equ b01200 
q3brate equ b09600 


9600 Baud for Intersystem 
1200 Baud for Clock 
1200 Baud for Transmodem 
9600 Baud for NEC Printer 


********************************************** ******** 

* 

* 

* Miscellaneous Constants * 


***************************************************************** 
11h ;X-ON 
13h ;X-OFF 
* 2 * ;*Z 

djeprom+400h ;Base of DJ RAM 
djram+3 ;DJ Console Input 
djram+6 ;DJ Console Output 


XON 

equ 

XOFF 

equ 

CTRLZ 

equ 

d J ram 

equ 

djcin 

equ 

djcout 

equ 


* . ^************** 

I I h !, ,0l !? wi 5L "• th * 280 Macro D^'^tlons which are used to * 

* define the Z80 Mnemonics used to implement the Z80 instruction* 

* set extensions employed in CBIOSZ. 

* * 

* 

**************** 


MACROS TO PROVIDE Z80 EXTENSIONS 
MACROS INCLUDE: 


$-MACRO 


;FIRST TURN OFF THE EXPANSIONS 


JR 

JRC 

JRNC 

JRZ 

JRNZ 

DJNZ 

LOIR 

LXXD 

SXXD 


JUMP RELATIVE 

JUMP RELATIVE IF CARRY 

JUMP RELATIVE IF NO CARRY 

JUMP RELATIVE IF ZERO 

JUMP RELATIVE IF NO ZERO 

DECREMENT B AND JUMP RELATIVE IF NO ZERO 

MOV @HL TO ®0E FOR COUNT IN BC 

LOAD DOUBLE REG DIRECT 

STORE DOUBLE REG DIRECT 
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r 


©GENDD MACRO USED FOR CHECKING AND GENERATING 
8-BIT JUMP RELATIVE DISPLACEMENTS 

©GENDD MACRO TDD ;;USED FOR CHECKING RANGE OF 8-BIT DISPLACEMENTS 
IF (TDD GT 7FH) AND (TDD LT 0FF80H) 

DB 100H ;Displacement Range Error on Jump Relative 

ELSE 

DB TDD 

ENDIF 

ENDM 

Z80 MACRO EXTENSIONS 


JR 

MACRO 

?N 


DB 

18H 


©GENDD 

ENDM 

?N-$-1 

JRC 

MACRO 

?N 


DB 

38H 


©GENDD 

ENDM 

?N-$-1 

JRNC 

MACRO 

?N 


DB 

30H 


©GENDD 

ENDM 

?N-$-1 

JRZ 

MACRO 

?N 


DB 

28H 


©GENDD 

ENDM 

?N-$-1 

JRNZ 

MACRO 

?N 


DB 

20H 


©GENDD 

ENDM 

?N-$-1 

DJNZ 

MACRO 

?N 


DB 

10H 


©GENDD 

ENDM 

?N-$-1 

LDIR 

MACRO 



DB 

ENDM 

0EDH.0B0H 

LDED 

MACRO 

?N 


DB 

0EDH,05BH 


DW 

ENDM 

?N 

LBCD 

MACRO 

?N 


DB 

0EDH.4BH 


DW 

ENDM 

?N 

SDED 

MACRO 

?N 


DB 

0EDH.53H 


DW 

ENDM 

?N 

SBCD 

MACRO 

?N 


DB 

0EDH.43H 


DW 

ENDM 

?N 


END OF Z80 MACRO EXTENSIONS 


{continued) 
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* 

Termln 01 drUer routines. Iobyte is tnitlollzed by the cold 
boot routine, to modify, chonge the "Intloby" equate. The 
I/O routines thot follow^oll work exoctly the some woy. Using 


xu ua » ., Vl ^ qAU '' l| y xne same woy. us i na * 

♦ ' th ;.° ddr ? 88 t0 J U, "P t0 ,n to execute. 


the desired function. There Is a 
each of the possible assignments 
the I/O routines for a different 
change the entries In the tables 


table with four entries for * 
for each device. To modify * 
I/O configuration, Just * 

* 




org 

equ 

I op 

100h-iop 

;Base Address of I/O Drivers 
{Offset for load via DDT or ZSID 

Jmp 

Jmp 

jmp 

status 
se1ect 
namer 

;Interna 1 Status Routine 
;Device Select Routine 
;Device Name Routine 

jmp 

t In i t 

;Initia 1ize Termina1 

jmp 

jmp 

jmp 

const 
con I n 
conout 

;Console Input Status 
{Console Input Char 
{Console Output Char 

jmp 

1 I st 

{List Output Char 

jmp 

punch 

{Punch Output Char 

jmp 

reader 

{Reader Input Char 

Jmp 

1Istst 

{List Output Status 

jmp 

newio 

;New I/O Driver Installation Routine 

jmp 

jmp 

copen 
cclose 

;Open CON: Disk FIle 
iCIose CON: Disk File 

jmp 

jmp 

1 open 

1c1ose 

;Open LST: Disk File 
iCIose LST: Disk File 


I/O Package Identification 
db ’Z3I0P’ 


;Reod by Z3L0ADER 


* 


************* 


status: return information on devices supported by this 

I/O Package On exit. HL points to a logical device 
table which is structured as follows: 

Device Count Byte Current Assignment Byte 


CON 

RDR 

PUN 

LST 


If error 
Also, if 


0 

2 

4 

6 

support, 
A=DrIver 


return 
ModuIe 


1 

3 

5 

7 

with Zero 
Number 



FIag Set. 


* 

* 

* 

* 

* 

* 

* 

* 

* 

* 

* 

* 

* 

* 


********* 


Ixi h,cnttbl 
mvi a,81H 

ora a 

ret 


;point to table 

;Module 1 (SVSIO) with Disk Output 
;Set Flags 
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***************************************************************** 
* * 

* select: select devices indicated by B and C. B is the number * 

* of the logical device, where CON:=0, RDR:«1, PUN:*2, * 

* LST:=3, and C is the desired device (range 0 to dev-1). * 

* Return with Zero Flag Set if Error. * 

* * 
***************************************************************** 
ranger: 


rang: 


rangok: 


rangerr: 


se I ect: 


se 12: 


se 13: 


se I 4: 


1 x i 

h.cnttbl 

-2 ;check for error 

inr 

b 

;range of 1 to 4 

mov 

a ,b 

;Value in A 

cp i 

5 

;B out of range? 

jnc 

rangerr 


push 

b 

;save params 

i nx 

h 

;pt to next 

i nx 

h 


d jnz 

rang 


mov 

b ,m 

;get count in b 

mov 

a, c 

;get selected device number 

cmp 

b 

;compare (C must be less than 

pop 

b 

;get params 

jrnc 

rangerr 

;range error If C >■ B 

xra 

a 

;0K 

dcr 

ret 

a 

;set flags (0FFH and NZ) 

xra 

ret 

a 

;not OK (Z) 

ca 1 I 

ranger 

;check for range error 

rz 


;abort if error 

i nx 

h 

;pt to current entry number 

mov 

m, c 

;save selected number there 

Ixi 

h ,cfgtb 

1-2 ;pt to configuration 

i nx 

h 

;Pt to Entry In Configuration 

l nx 

h 


d jnz 

se 1 2 


mov 

b ,m 

;Get Rotate Count 

1 nx 

h 

;Pt to Select Mask 

mov 

d ,m 

;Get Select Mask 

mov 

a,b 

;Any Rotation to do? 

ora 

a 


Jz 

se 1 4 


mov 

a, c 

;Get Selected Number 

r 1 c 


;Rotate Left 1 Bit 

d jnz 

se 13 


mov 

c,a 

;Place Bit Pattern Back in C 

1 da 

lobyte 

;get I/O byte 

ana 

d 

;mask out old selection 

ora 

c 

;mask in new selection 

sta 

1obyte 

;put I/O byte 

Jr 

rangok 

; range OK 


***************************************************************** 


* 

* namer: 

* 

* 

* 

* 

* 

* 

* 

* 


: return text string of physical device. Logical device 
number is in B and physical selection is in C. 

HL is returned pointing to the first character of the 
string. The strings are structured to begin with a 
device name followed by a space and then a description 
string which is terminated by a binary 0. 

Return with Zero Flag Set if error. 


***************************************************************** 
namer: 


ca 1 1 

ranger 

;check 

for range error 

rz 


;return 

I f so 

Ixi 

h ,namptb1-2 

;pt to name ptr table 

ca 1 1 

namse1 

;se1ect 

ptr table entry 


{continued} 
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b,c ;phy$icol selection number in B now 
b ;Add 1 for Initial Increment 

namsel ;point to string 

rongok jreturn with HL pointing and range OK 

V" 6y HLi ,ruy '* « w- 


mov 
Inr 
ca I I 

Jr 


namseI: 


Inx 

h 

Inx 

h 

d jnz 

namse1 

mov 

a ,m 

1 nx 

h 

mov 

h,m 

mov 

ret 

1 . a 


;pt to next entry 

;get low 
;get high 

;HL now points to entry 


* const: get the status for the currently assigned console * 

The I/O Byte is used to select the device. * 

const: *************************** 

;Beglnnlng of Jump table 


conmask: 


h.cstble 


d,cfgtbl 
seI dev 


;Pt to First Entry In Conflg Table 
;Select correct Jump 


* 

* conin: Input a character from the currently assigned console. * 
The I/O Byte is used to select the device. « 

con In: 

[ X[ h.citble ;Beginning of character Input table 

J r conmask ;Get Console Mask 


* conout: output the character In C to the currently assigned 
console. The I/O Byte is used to select the device. 



Ixi 

h,cotb1e 

cal 1 

crout 

Jr 

conmask 


;Beginning of the character out table 
;output to console recorder if set 
;Get Console Mask 

* csreader: get the status of the currently assigned reader. * 

The I/O Byte is used to select the device. * 

* 

csreadr********************************************************** 

. , 1x1 h,csrtbIe beginning of reader status table 

r armask: 

Ixi d,cfgtbl+2 ;Pt to 2nd Entry in Config Table 

Jr seldev 

************************************++*+*++++++++++***++********* 

* reader: input a character from the currently assigned reader. * 

* The I/O Byte is used to select the device • 

* ^ 

reader: ************************** 

Ixi h.rtble beginning of reader input table 

J r rdrmask ;Get the Mask and Go 
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***************************************************************** 


* * 

* Entry at seldev will form an offset into the table pointed * 

* to by H&L and then pick up the address and jump there. * 

* The configuration of the physical device assignments is * 

* pointed to by D&E (cfgtbl entry). * 

* * 


***************************************************************** 
seI dev: 


push 

b 

Save Possible Char in C 

1 dax 

d 

Get Rotate Count 

mov 

b, a 

... i n B 

inx 

d 

Pt to Mask 

1 dax 

d 

Get Mask 

cma 


Flip Bits 

mov 

c,a 

... in C 

Ida 

iobyte 

Get I/O Byte 

ana 

c 

Mask Out Selection 

inr 

b 

Increment Rotate Count 

dcr 

b : 

;Count down 

jrz 

se 1 d2 


r rc 

1 

;Rotate Right one Bit 

Jr 

seldl 


r 1 c 

i 

[Double Number for Table 

mv i 

d.0 

;Form offset 

mov 

e,a 


dad 

d 

;Add offset 

mov 

a ,m 

[Pick up low byte 

i nx 

h 


mov 

h ,m 

[Pick up high byte 

mov 

1 .a 

[Form address 

pop 

b 

[Get Possible Char in C 

pch 1 


;Go there ! 


***************************************************************** 


* * 

* punch: output char in C to the currently assigned punch * 

* device. The I/O Byte Is used to select the device. * 

* * 


***************************************************************** 
punch: 

Ixi h.ptble [Beginning of punch table 

Ixi d,cfgtbI+4 ;Get Mask 

jr seldev ;Select Device and Go 


***************************************************************** 
* * 

* list: output char in C to the currently assigned list device. * 

* The I/O Byte is used to select the device. * 

* * 
***************************************************************** 


list: 

ixi 

h,1tble 

[Beginning of the list device routines 


ca 1 1 

1 rout 

[output to list recorder if set 

Istmask: 

Ixi 

d,cfgtb1+6 

[Get Mask 


Jr 

se1 dev 

[Select Device and Go 


***************************************************************** 
♦ * 

♦ Listst: get the output status of the currently assigned list * 

♦ device. The I/O Byte is used to select the device. * 

♦ * 
***************************************************************** 
I i stst: 


Ixi h,Istble 

Jr Istmask 


beginning of the list device status 
;Mask and Go 


( continued ) 
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***************************************************************** 
* * 

♦ If customizing I/O routines is being performed, the tables * 

♦ below should be modified to reflect the changes. All I/O * 

♦ devices are decoded out of lobyte and the Jump Is taken from * 

♦ the following tables. * 

♦ * 
***************************************************************** 

***************************************************************** 
* * 

* I/O Driver Support Specification Tables * 

* * 
***************************************************************** 


♦ Device Counts 


* First 

Byte is Number of 

Devices, 2nd 

Byte 

> is 

Se1ected 

cnttbl: 






db 

$,(intioby AND 7) 


CON 


db 

2, (1nt1oby AND 

08h) SHR 3 


RDR 


db 

2.(intioby AND 

10h) SHR 4 


PUN 


db 

6,(Intioby AND 0E0h) SHR 5 


LST 


* 

* Configurati 

on Table 





* First 

* 

Byte is Rotate Count, 2nd Byte 

i is Mask 


cfgtbl: 






db 

0,111$1$1$000b 

;No Rotate, 

Mask 

Out 

3 LSB 

db 

3,111$1$0$111b 

;3 Rotates, 

Mask 

Out 

Bit 3 

db 

4,111$0$1$ 111b 

;4 Rotates, 

Mask 

Out 

Bit 4 

db 

5,000$1$1$111b 

;5 Rotates, 

Mask 

Out 

3 MSB 

♦ 

* name text tables 





namptb1: 






dw 

conname-2 

;CON: 




dw 

rdrnome-2 

;RDR: 




dw 

punname-2 

; PUN: 




dw 

1 stname-2 

; LST: 




conname: 






dw 

namcrt ;CRT 






dw 

dw 

dw 

dw 

dw 


Istname: 


dw 

dw 

dw 

dw 

dw 

dw 


namusr ;CRT and Modem in Parallel 
namusrl ;CRT Input and CRT/Remote Computer Output 
namusr2 ;CRT Input and CRT/Modem Output 
namcrtt ;CRT Input and CRT/TTY Printer Output 
namcrtn ;CRT Input and CRT/NEC Printer Output 


namtty ;TTY 
namcrt ;CRT 
namrem ;Remote Computer 
nammod ;Modem 
nammpu ;MPU 


nammpu8 ;MPU with 8 Bits 


rdrname: 


dw 

dw 


nammod ;Modem 
namclk ;Clock 


punname: 


dw nammod ;Modem 

dw namclk ;Clock 


nammpu: 

nammpu8: 

namtty: 


namcrt: 


db *TTY Toshiba P1350 Printer*,0 

db ’TTY8 TTY with 8th Sig Bit\0 

db ’NEC NEC 3510 LQ Printer’.0 

db ’CRT TVI 950 CRT',0 
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namcrtn: 

db 'CRTNEC CRT Input and CRT/NEC Printer Output*,0 

namcrtt: 

db *CRTTY CRT Input and CRT/TTY Printer Output*,0 

namusr: 

db *CRTMOD CRT and Modem in Parallel*,© 

namusr 1: 

db *CRTREM CRT Input and CRT/Remote Output’,0 

namusr2: 

db *CRTMOD2 CRT Input and CRT/Modem Output*,© 

namrem: 

db ‘REMOTE Remote Computer’,0 

nammod: 

db 'MODEM Transmodem 1200’,0 

namclk: 

db 'CLOCK DC Hayes Chronograph*,© 


* console input table 

* 

citble: 


dw 

cicrt 

;Input 

from 

crt 

dw 

c iusr 

; Input 

from 

crt 

dw 

cicrt 

;Input 

from 

crt 

dw 

cicrt 

;Input 

f rom 

crt 

dw 

cicrt 

;Input 

from 

crt 

dw 

cicrt 

;Input 

from 

crt 


* console output table 

* 

cotbIe: 


dw 

cocrt 

{Output 

to 

crt 

dw 

cousr 

•.Output 

to 

crt 

dw 

cousr1 

;0utput 

to 

crt 

dw 

cousr 

;Output 

to 

crt 

dw 

cocrtt 

;Output 

to 

crt 

dw 

cocrtn 

;Output 

to 

crt 


* list device tab Ie 


( 000 ) 

and modem (001) 
(010) 

( 011 ) 



( 000 ) 

and modem (001) 

and remote system (010) 

and modem (011) 

and TTY printer (100) 

and NEC printer (l® 1 ) 


Itble: 



dw 

cot ty 

{Output 

to 

tty (000) 


dw 

cocrt 

;Output 

to 

crt (001) 


dw 

corem 

;Output 

to 

remote system (010) 


dw 

comod 

;0utput 

to 

modem (011) 


dw 

compu 

;Output 

to 

mpu (100) 


dw 

compu8 

{Output 

to 

mpu (101) 

* 

* punch 

* 

device 

tab 1 e 




ptb1e: 







dw 

comod 

;0utput 

to 

modem (0) 


dw 

coc 1 k 

;Output 

to 

clock (1) 

* 

* reader 

• device 

table 




rtb1e: 







dw 

c imod 

;Input 

from modem (0) 


dw 

ciclk 

; Input 

from clock (1) 


* console status table 

♦ 

cstbIe: 


dw 

cscrt 

;Status 

from 

crt 

dw 

csusr 

{Status 

from 

crt 

dw 

cscrt 

{Status 

f rom 

crt 

dw 

cscrt 

{Status 

from 

crt 

dw 

cscrt 

{Status 

from 

crt 

dw 

cscrt 

{Status 

from 

crt 


( 000 ) 

and modem (001) 

( 010 ) 

( 011 ) 

( 100 ) 

( 101 ) 


( continued ) 
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* 


* status from 

reader device 




♦ 

csrtble: 





dw 

csmod 

{Status 

from 

modem (0) 

dw 

esc 1 k 

{Status 

from 

clock (1) 

* 

* Status from 

1 1st devIce 




* 

1 stb1e: 





dw 

costty 

{Status 

from 

tty (000) 

dw 

coscrt 

{Status 

from 

crt (001) 

dw 

cosrem 

{Status 

from 

remote system (010) 

dw 

cosmod 

{Status 

from 

modem (011) 

dw 

cosmpu 

{Status 

from 

mpu (100) 

dw 

cosmpu 

{Status 

from 

mpu (101) 


***************************************************************** 
* * 

* Tinit can be modified for different I/O setups. * 

* * 

***************************************************************** 
tinit: {Initialize the terminal routine 


Initialize I/O Byte 

mvi a.intioby {Initialize IOBYTE 

sta iobyte 


Initialize 
mv i 


out 
Ixi 
mov 
out 
mov 
out 
mv i 


out 
xra 
out 
out 
mv i 
out 


MPU Serial I/O Channel Characteristics and Baud Rate 


a,10$00$00$11b 


mpuIcr 
h.mpbrate 
a,I 

mpudI I 
a,h 

mpudIh 

a,00$00$00$11b 


mpuIcr 
a 

mpuier 
mpustat 
a,0000$1111b 
mpupcr 


Access Divisor: 

10 — Set divisor latch, clear break 
00 — 0 parity bit, odd parity (N/A) 

00 — disable parity, 1 stop bit 

11 — 8 Data Bits 

To Line Control Register 
HL = MPU Channel Baud Rate 
Set Low-Byte of Baud Rate 
To Divisor Latch Low 
Set High-Byte of Baud Rate 
To Divisor Latch High 

Reset Divisor Access and Set Characteristics: 
00 — Clear divisor latch, clear break 
00 — 0 parity bit, odd parity (N/A) 

00 — disable parity, 1 stop bit 
11 — 8 Data Bits 
To Line Control Register 
A=0 

Disable All Interrupts in Interrupt Register 
Clear All Error Flags in Line Status Register 
3 Zeroes, No Loop. 1, Set RLSD, CTS, DSR 
To Peripheral Control Register 


Initialize Quad I/O Channel 
mvi a,10$11$01$11b 


caI I setquad 

mvi a,01$11$01$11b 


caIi setquad 

mvi a,11$00$11$10b 


caI I setquad 

mvi a,00$11$01 $11b 


Characteristics 
-.Genera 1-Purpose Reset: 

; 10—1 1/2 Stop Bits 

; 11 — Even Parity, Enable Parity 

; 01 — 6 Bits/Char 

; 11 — 64x Baud Rate 

;Set AI I 4 Quad I/O Ports 
;Genera1-Purpose Reset: 

; 01 — Disable Hunt, Internal Reset 

; 11 — RTS High, Error Reset 

; 01 — No Break, Enable RxRDY 

; 11 — NOT DTR High, Enable TxEN 

;Set AI I 4 Quad I/O Ports 
;Characteristics Set for All: 

; 11—2 Stop Bits 

; 00 — No Parity 

; 11 — 8 Bits/Char 

; 10 — 16x Baud Rate 

;Set AI I 4 Quad I/O Ports 
;Characteristics Set for All: 

; 00 — Disable Hunt, No Internal Reset 

; 11 — RTS High. Error Reset 

; 01 — No Break, Enable RxRDY 
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; 1 

caI I setquod • ;Set 

Initialize Quad I/O Baud Rates 


mvi 

a,q0brate 

;Set 

out 

q0baud 


mv i 

a,qlbrate 

;Set 

out 

qlbaud 


mv i 

a,q2brate 

;Set 

out 

q2baud 


mv i 

a,q3brate 

;Set 

out 

q3baud 



— NOT DTR High, Enable TxEN 
AI I 4 Quad I/O Ports 

USART 0 Baud Rate 
USART 1 Baud Rate 
USART 2 Baud Rate 
USART 3 Baud Rate 


; Set AI I Recording OFF 
xra a 

sta crecord 

sta Irecord 


; A=0 

;consoIe 
; I ist device 


Clear Garbage Char from CRT 
caI I cscrt 

ora a 

cnz cicrt 

ret 


;Gobble up unwanted char 
;A=0 if none 
;Grab character 


; Set AI I Quad 
setquad: 

out 

out 

out 

out 

xth I 

xth I 

ret 


I/O Control Ports 


q0stat 

qlstat 

q2stat 

q3stat 


USART 0 
USART 1 
USART 2 
USART 3 
Long Delay 


***************************************************************** 


* * 

* NEWIO — Set UC1: Device to the Device Drivers whose Jump * 

* Table is Pointed to by HL * 

* * 

* This Jump Table is structured as follows: * 

* JMP ISTAT <— Input Status (0«No Char, 0FFH*Char) * 

* JMP INPUT <~ Input Character * 

* JMP OUTPUT <— Output Character In C * 

* * 

* The Base Address of this Jump Table (JBASE) is passed to * 

* NEWIO in the HL Register Pair. * 

* * 


***************************************************************** 

newio: 


shld 

cstb1e+6 

;Set UC1: Input Status 

Ixi 

d, 3 

;Prepare for offset to next 

dad 

d 

;HL points to next jump 

sh 1 d 

citb1e+6 

;Set UC1: Input Character 

dad 

d 

;HL points to next jump 

sh 1 d 
ret 

cotb1e+6 

;Set UC1: Output Character 


***************************************************************** 


* * 

* Input Status, Input Character, and Output Character * 

* Subroutines for CP/M * 

* * 

***************************************************************** 
* * 

* Input Status — * 

* These routines return 0 In the A Register if no Input * 

* data is available, 0FFH if input data is available. * 

* * 

* Input Character — * 

* These routines return the character (byte) in the A * 

* Register. MSB Is masked off. * 


( continued ) 
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* * 

* Output Character — * 

* These routines output the character (byte) In the C * 

* Reg Ister. * 

* * 


♦***♦♦*♦♦♦♦♦♦***♦♦♦♦♦♦♦♦♦♦*♦*♦♦♦♦*♦***♦*♦**♦*♦**♦*♦*♦♦♦*♦***♦***♦ 


***************************************************************** 
♦ * 

* CRT Input Status, Input Character, and Output Character * 

♦ * 
***************************************************************** 


cscrt 

equ 

$ 

;CRT Input Status 


Ida 

ustat 

;Get Status 


cma 


jlnverted Logic 


an 1 

1 stat 

;Mask for Input status and fa 


Jr 

stat 

;Set Flags 

coscrt 

equ 

$ 

;CRT Output Status 


Ida 

ustat 

;Get USART status 


cma 


jlnverted Logic 


an I 

ostat 

jMask for output status 


Jr 

stat 

jReturn 

clcrt 

equ 

$ 

;CRT Input 


jmp 

d jcin 

;Get char 

cocrt 

equ 

$ 

;CRT Output 


jmp 

djcout 

;Put char 

cocrtt 

equ 

$ 

;CRT and TTY Printer Output 


push 

b 

jSave char 


ca 1 1 

d jcout 

;CRT Output 


pop 

b 

;Get char 


jmp 

compu 

jPrinter Output 

cocrtn 

equ 

$ 

;CRT and NEC Printer Output 


push 

b 

jSave char 


ca 1 1 

djcout 

;CRT Output 


pop 

b 

;Get char 


jmp 

cot ty 

jPrinter Output 


***************************************************************** 
* * 

* Modem Input Status, Input Character, and Output Character * 

* * 
***************************************************************** 


csmod 

equ 

in 

$ 

mods 

jModem Input Status 


an i 

jr 

mrda 

stat 

;Data avai1ab1e? 

cosmod 

equ 

$ 

jModem Output Status 


in 

mods 

;Get status 


an i 

Jr 

mtbe 

stat 

;TBE? 

c i mod 

equ 

$ 

•.Modem Input Character 


ca 1 1 
jrz 

csmod 
c i mod 

; RDA? 


in 

modd 

jGet data 


an i 
ret 

7fh 

jMask 

comod 

equ 

$ 

jModem Output 


ca 1 1 
jrz 

cosmod 

comod 

;TBE? 


mov 

a,c 

;Get char 


out 

ret 

modd 

;Put data 
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***************************************************************** 
* * 

* Clock Input Status, Input Character, and Output Character * 

* * 
***************************************************************** 


esc 1 k 

equ 

$ 


i n 

qlstat 


an i 

qrda 


Jr 

stat 

cosc1k 

equ 

$ 


1 n 

qlstat 


an i 

qtbe 


Jr 

stat 

ciclk 

equ 

$ 


cal 1 

esc 1 k 


Jrz 
i n 

ciclk 


qldata 


an I 
ret 

7fh 

coc 1 k 

equ 

$ 


cal 1 

cosc1k 


jrz 

coc 1 k 


mov 

a.c 


out 

ret 

qldata 


;TTY Input Status 
;Get Status 
;Data avaiIabIe? 


TTY Output Status 
Get Status 
TBE? 


;TTY Input Character 
;RDA? 

;Get data 
;Mask 


;TTY Output Character 
; TBE? 

;Get data 
;Put data 


***************************************************************** 
* * 


* This is a common return point to correctly set the return * 

* status flags; It is centrally located for the jump * 

* relative instructions * 

* * 


***************************************************************** 
stat: 

rz ;Nothing found 

ready: 

mvi a,0ffh ;Set A for negative status 
ret 


***************************************************************** 


* * 

* NEC Input Status, Input Character, and Output Character * 

* X-OFF Processing Added * 

* * 


***************************************************************** 


cstty 

equ 

$ 

;TTY Input Status 


in 

q3stat 

;Get Status 


an i 

Jr 

qrda 

stat 

;Data avai1ab1e? 

costty 

equ 

$ 

;TTY Output Status 


in 

q3stat 

;Get Status 


an i 

Jr 

qtbe 

stat 

;TBE? 

citty 

equ 

$ 

;TTY Input Character 


cal 1 
jrz 

cstty 

citty 

;RDA? 


i n 

q3data 

;Get data 


an i 
ret 

7fh 

;Mask 

cotty 

equ 

$ 

;TTY Output Character 


ca 1 1 

cstty 

;Any character? 

cottyl: 

jrnz 

cotty2 

jProcess if so 


cal 1 
jrz 

costty 

cottyl 

;TBE? 


mov 

a,c 

;Get data 


out 

ret 

q3data 

;Put data 


[continued) 


BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 81 







October 


cotty2: 


cal 1 

ci tty 

;X-OFF? 

cpi 

XOFF 

;Do nothing If not X 

jrnz 

cottyl 


ca 1 1 

ci tty 

;Wait for next char 

Jr 

cottyl 



***************************************************************** 
* * 
* Remote System Input Status, Input Character, and Output * 


Character 


***************************************************************** 


csr em 

equ 

$ 

;TTY Input Status 


i n 

qOstat 

;Get Status 


an i 

qrda 

;Data avai1ab1e? 


Jr 

stat 


cosrem 

equ 

$ 

;TTY Output Status 


in 

qOstat 

;Get Status 


an i 

qtbe 

;TBE? 


Jr 

stat 


ci rem 

equ 

$ 

;TTY Input Character 


ca 1 1 

csrem 

;RDA? 


Jrz 

c I rem 



i n 

qOdata 

;Get data 


an i 

7fh 

;Mask 


ret 



corem 

equ 

$ 

;TTY Output Character 


ca 1 1 

coxoff 

;Check for XOFF and process 


ca 1 1 

cosrem 

;TBE? 


Jrz 

corem 



mov 

a,c 

;Get data 


out 

qOdata 

;Put data 


ret 



coxoff 

equ 

$ 

;Remote XOFF Check and Processing 


ca 1 1 

csrem 

;Input Char from 1ST: Device? 


rz 


;Zero If none 


cal 1 

cl rem 

;Get Char 


cpi 

XOFF 

;XOFF? 


rnz 


;Return if not 


ca i 1 

ci rem 

;Wait for Any Other Char 


ret 




***************************************************************** 
* * 

* TTY Input Status, Input Character, and Output Character * 

* X-OFF Processing Added * 

* * 
***************************************************************** 


csmpu 

equ 

$ 

;TTY Input Status 

in 

mpustat 

;Get Status 


an i 

mpurda 

;Data avaliable? 


Jr 

stat 


cosmpu 

equ 

$ 

;TTY Output Status 


i n 

mpustat 

;Get Status 


an i 

mputbe 

;TBE? 


Jr 

stat 


c impu 

equ 

$ 

;TTY Input Character 


ca 1 1 

csmpu 

;RDA? 


Jrz 

cimpu 



i n 

mpudata 

;Get data 


an i 

7fh 

;Mask 


ret 



compu8 

equ 

$ 

;TTY Output Character 

mv i 

a,0f fh 

;8th Bit Allowed 


Jr 

compu0 


compu 

equ 

$ 

;TTY Output Character 


mv i 

a,07fh 

;No 8th Bit 
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compu0: 



sta 

mpumask 



ca I 1 

csmpu 

;Any character? 


jrnz 

compu2 

;Process if so 

compul: 

ca 1 1 

cosmpu 

;TBE? 


Jrz 

compul 



mov 

a, c 

;Get data 


an i 

0ffh 

;Mask 

mpumask 

equ 

$-1 

;Address of Mask 


out 

mpudata 

;Put data 


ret 



compu2: 

ca 1 1 

cimpu 

;X-OFF? 


cp i 

XOFF 

;Do nothing if not 


j rnz 

compul 



ca 1 1 

cimpu 

;Wait for next char 


jr 

compul 



***************************************************************** 


* User-Defined (CRT and Modem) Input Status, Input Character, 

* 

* 


and Output Character 


***************************************************************** 


csusr 

equ 

$ 

;User (CRT and Modem) Input Status 


ca 1 1 

cscrt 

;Input from CRT? 


rnz 


;Char found 


ca 1 1 

csmod 

; Input from Modem? 


ret 



cosusr 

equ 

cosmod 

;Output status same as modem since modem is 

c iusr 

equ 

$ 

;Modem/CRT Input Combination 


ca 1 1 

cscrt 

; Input from CRT? 


jnz 

clcrt 

;Get char from CRT 


ca 1 1 

csmod 

; Input from Modem? 


jnz 

c i mod 

;Get char from Modem 


jr 

ciusr 

;Continue 

cousr 

equ 

$ 

;Modem/CRT Output Combination 


ca 1 1 

comod 

;Output to Modem 


jmp 

cocrt 

;Output to CRT 

ciusr 1 

equ 

$ 

;Modem/CRT Input w/CRT Output Combination 


ca 1 1 

ciusr 

;Get char 


push 

psw 

;Save char in A 


mov 

c, a 

;Char in C 


cal 1 

cocrt 

;Output to CRT 


pop 

psw 

;Restore char in A 


ret 



cousr 1 

equ 

$ 

;Remote System/CRT Output Combination 


ca 1 1 

corem 

;Output to Remote System 


jmp 

cocrt 

;Output to CRT 

***************************************************************** 

* 

* Record Output 

Routines 

* 

! * 

* 

CROUT - 

Conso1e 

Recorder * 

* 

* 

LROUT - 

List Recorder * 

***************************************************************** 

crout 

equ 

$ 



1 da 

crecord 

;get flag 


ora 

a 

;test flag for 0 (no recording) 


rz 




mov 

a, c 

;check char 


an 1 

7fh 



cpi 

ctr 1 z 

;don't allow 


rz 




Jmp 

corem 

jremote output if flag set 


(i continued ) 

BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER 1986 83 






October 


equ 

S 


Ida 

1 record 

;get flag 

ora 

a 

;test flag for 0 (no recording) 

rz 



mov 

a, c 

;check char 

an i 

7fh 


cpi 

ctrlz 

;don * t allow *Z 

rz 



jmp 

corem 

;remote output if flag set 


COPEN — Open Console File for Output 
LOPEN — Open Printer File for Output 


w 

» 

Turn 

Appropriate Flag ON 

» 

copen: 

mv I 

a,0ffh ;set flag 


Jr 

ccrset 

lopen: 

mvi 

a,0ffh ;set flag 


Jr 

1crset 


; Close Disk Files 
; CCLOSE — CON fIle (DSK1) 

; LCLOSE — LST file (DSK2) 

• 

; Send to Terminate File Recording and Zero Appropriate Flag 

» 

cclose: 

mvi c,ctrlz ;send ctrlz 

caI I corem 

xra a 

ccrset: 

sta crecord ;set flag off 

ret 

Iclose: 

mvi c,ctrlz ;send ctrlz 

caI I corem 

xra a 

I crset: 

sta Irecord ;set flag off 

ret 


; Recording Buffers 
crecord: 

ds 1 

I record: 

ds 1 


; Test for Size Error 

if ($ GT (IOP + I0PS*128)) 

sizerr equ novalue ;IOP is too large for buffer 
end i f 

end 


;console device 
;Iist device 


SYSENV.LIB 

"CP/M Hall of Fame," by Brock N. Meeks, October 1986, page 219. 


LIBRARY: SYSENV.LIB 
AUTHOR: Richard Conn 

Version: 1.0 

Date: 18 May 84 

Previous Versions: None 
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SYSENV is the definition for my ZCPR3 environment. 


sysenv macro 
; Environment Descriptor 

; If inline, there is a leading JMP just before this 

f 

envorgl: 


db 

’Z3ENV* 

; Environment ID 

db 

2 

; class 2 environment (internal) 

dw 

expath 

; external path address 

db 

expaths 

; number of 2-byte elements in path 

dw 

rep 

; RCP address 

db 

reps 

; number of 128-byte blocks in RCP 

dw 

iop 

; IOP address 

db 

iops 

; number of 128-byte blocks in IOP 

dw 

f cp 

; FCP address 

db 

f cps 

; number of 128-byte blocks in FCP 

dw 

z3ndir 

; NDR address 

db 

z3ndirs 

; number of 18-byte entries in NDR 

dw 

z3c 1 

; ZCPR3 Command Line 

db 

z3c 1 s 

; number of bytes in Command Line 

dw 

z3env 

; ZCPR3 Environment Descriptor 

db 

z3envs 

; number of 128-byte blocks in Descriptor 

dw 

shstk 

; Shell Stack address 

db 

shstks 

; number of shsize-byte entires in Shell Stack 

db 

shs i ze 

; size of a Shell Stack entry 

dw 

z3msg 

; ZCPR3 Message buffer 

dw 

extfeb 

; ZCPR3 External FCB 

dw 

extstk 

; ZCPR3 External Stack 

db 

0 

; quiet flag (1«quiet, 0=not quiet) 

dw 

z3wh 1 

; address of Wheel Byte 

db 

4 

; Processor Speed in MHz 

db 


; maximum disk 

db 

31 

; maximum user 

db 

1 

; 1-OK to accept DU, 0-not OK 

db 

0 

; CRT selection (0-CRT 0, 1-CRT 1) 

db 

0 

; Printer selection (n«Printer n) 

db 

80 

; width of CRT 0 

db 

24 

; number of lines on CRT 0 

db 

22 

; number of lines of text on CRT 0 

db 

132 

; width of CRT 1 

db 

24 

; number of lines on CRT 1 

db 

22 

; number of lines of text on CRT 1 

db 

80 

; width of Printer 0 

db 

66 

; number of lines on Printer 0 

db 

58 

; number of lines of text on Printer 0 

db 

1 

; form feed flag (0-can’t formfeed, 1«can) 

db 

102 

; width of Printer 1 

db 

66 

; number of lines on Printer 1 

db 

58 

; number of lines of text on Printer 1 

db 

1 

; form feed flag (0-can’t formfeed, 1-can) 


( continued ) 
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db 

80 ; 

width of Printer 2 

db 

66 ; 

number of lines on Printer 2 

db 

58 

number of lines of text on Printer 2 

db 

0 ; 

form feed flag (0«can*t formfeed, 1«can) 

db 

102 ; 

width of Printer 3 

db 

66 : 

number of lines on Printer 3 

db 

58 ; 

number of lines of text on Printer 3 

db 

0 ; 

form feed flag (0«con*t formfeed, 1«can) 

db 

* SH 1 ; 

shell variable filename 

db 

'VAR * 

she 11 variable flletype 

db 

* * • 

• 

fI1ename 1 

db 

* * • 

fi1etype 1 

db 

» » , 

• 

f11ename 2 

db 

• » . 

> 

fIletype 2 

db 

* * • 

» 

fi1ename 3 

db 

* » . 

• 

fi1etype 3 

db 

* » . 

» 

f11ename 4 

db 

* * • 

fI 1etype 4 

ds 

80H-($-envorg1+3) 

; make exactly 80H bytes long 


; (+3 compensates for leading JMP) 

» 

; Terminal Capabilities Data 
envorg2: 


DB 

*TVI 950 

;Name of Terminal 

DB 


;Cur sor UP 

DB 


;Cursor DOWN 

DB 

*L 

;Cursor RIGHT 

DB 

*H*-*®* 

;Cursor LEFT 

DB 

00 

;CL Delay 

DB 

00 

;CM Delay 

DB 

00 

;CE Delay 

DB 

Ibh,,0 

;CL String 

DB 

Ibh,*■%+ %+ •,0 

;CM String 

DB 

Ibh,* t *,0 

;CE String 

DB 

Ibh, * ) * ,0 

;SO String 

DB 

Ibh,•(•,0 

;SE String 

DB 

0 

;TI String 

DB 

0 

;TE String 

ds 

80H-($-envorg2) 

; make exactly 80H bytes long 


End of Environment Descriptor 
endm 


Z80MU310.TXT 

"Z80MU," by Robert A. Baumann, October 1986, page 203. 


Z80MU Information 


release 3.10 of Z80MU.EXE, dated 3/14/86 


Z80MU is a Z80 and CP/M 2.2 Emulator which runs on the IBMPC. It was 
written by Joan Riff for Computerwise Consulting Services. We have used 
it for the various projects that we needed it for, and rather than have 
the thing collect dust on the shelf we have decided to release it to the 
public domain so that it may find its way into the hands of whoever 
could use it. 
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WE NEED YOUR HELP!!! 

Please help the Public Domain world in the following ways: 

1) Feel free to distribute Z80MU310.ARC (the original Emulator ARC 
file), along with this file (Z80MU310.TXT). Don’t change their names, Do 
not try to rebuild an ARC file from the component files unless you are 
very careful. We much prefer that you keep a copy of the original ARC 
file around for uploading. If you upload it to a bulletin board system, 
please be VERY careful to make sure that a good upload is obtained. To 
be safe, download the thing back (under a different name) and use ARC to 
expand it. If you get a good expansion, then you know that the upload 
was good. WE HAVE SEEN MANY GARBAGED (BAD CHECKSUM) COPIES OF THE ARC 
FILE ON VARIOUS BULLETIN BOARDS. This hurts everybody. If you discover a 
garbaged version of the ARC file on a bulletin board, please notify the 
Sysop, and upload a good version. 

2) Keep your eyes open for new releases of the Emulator. 

3) Please forward bug reports to us (on disk). We’ll fix ’em if and 
when we can. This gives us a better version for our own continued use, 
and we’ll release the fixed one to various bulletin boards. We have 
already received several "Hey! This CP/M program doesn’t work!" reports 
from users, which have resulted in the improvement of the Emulator. It 
now runs a much larger universe of CP/M software, thanks to feedback 
from the field. 


FILES IN THE , ARC FILE 


The files in the ARC file are as follows: 


Z80MU 

EXE 

97696 

3-25-86 

2:56a 

The Emulator 

Z80MU 

DOC 

203232 

4-11-86 

2:44a 

The User’s Guide 

820INIT 

COM 

640 

11-24-85 

12:02a 

RESOURCE test file (object) 

820INIT 

CTL 

3443 

11-24-85 

8:14p 

Control file for 820INIT.COM 

820INIT 

ASM 

6373 

11-24-85 

8:15p 

Resultant source code 

820INIT 

PRN 

20608 

11-24-85 

8:17p 

Resultant assembly listing 


IMPLEMENTATION HINTS 

This new version runs a much wider universe of CP/M software than the 
previous ones did. 

When in doubt, configure your CP/M program to use a VT52 (Heath/Zenith 
H-19 or Z-19) terminal. Then use the Emulator command "TERMINAL BOTH" to 
send BIOS and BOOS console I/O through the built-in VT52 emulator. Once 
you have things figured out, you can put the proper "TERMINAL" command 
in your AUTOEXEC.Z80 file. 


STICKY WICKETS 

If you STILL can't get your CP/M program to run under the Emulator, 
then: 

1) It may not be "portable" enough. Sorry, we can’t work 
mi racIes. 

2) It may use a quirk of CP/M that we don’t currently (but may 
In the future) support. Send us a disk containing the offen¬ 
ding program, and a writeup of how to reproduce the problem. 

We may be Intrigued enough to debug your package. This may 
result in an improved Emulator which can handle your program. 
Then again, it may not. In either case, we destroy copies of 
your CP/M program once we’re done debugging it. 


(continued} 
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THINGS FIXED WITH 3.10: 

1) BDOS Func 10/0Ah is now done entirely by Z80MU (used to 
coll DOS). RETURN no longer required. 

2) VT52 clear-screen code is ESC E, not ESC F. 

3) FCB fields more closely emulated. 

4) Word of zeroes is put on stack prior to Transient entry at 
0100h. Bug in Lattice used to store zero word "elsewhere..." 

5) Keypress fights between PCDOS and VT52 emulator resolved. 
The VT52 emulator won. 

6) Disassembler (broken In 3.00) Is now fixed. 

7) CP/M results come back in HL as well as A-reg. 


Have fun! 

Computerwlse Consulting Services 
P.O. Box 813 
McLean * VA 22101 
(703) 280-2809 


820INIT.ASM 

"Z80MU," by Robert A. Baumann, October 1986, page 203. 


.Z80 ;This source is for M80.COM! 

ORG 00100H 


Equates for ASCII control chars 


NUL 

EQU 

000H 

SOH 

EQU 

001H 

STX 

EQU 

002H 

ETX 

EQU 

003H 

EOT 

EQU 

004H 

ENQ 

EQU 

005H 

ACK 

EQU 

006H 

BEL 

EQU 

007H 

BS 

EQU 

008H 

TAB 

EQU 

009H 

LF 

EQU 

00AH 

VT 

EQU 

00BH 

FF 

EQU 

00CH 

CR 

EQU 

00DH 

SO 

EQU 

00EH 

SI 

EQU 

00FH 

DLE 

EQU 

010H 

XON 

EQU 

011H 

DC 2 

EQU 

012H 

XOFF 

EQU 

013H 

DC4 

EQU 

014H 

NAK 

EQU 

015H 

SYN 

EQU 

016H 

ETB 

EQU 

017H 

CAN 

EQU 

018H 

EM 

EQU 

019H 

SUB 

EQU 

01 AH 

ESC 

EQU 

01BH 

FS 

EQU 

01CH 

GS 

EQU 

01DH 

RS 

EQU 

01EH 

US 

EQU 

01FH 

» 

External ref equates 
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IOPORT00H 
BOOS EQU 
IOPORT06H 


EQU 00000H 

00005H 

EQU 00006H 


End of external equates 


STARTUP: 

LD 

CALL 

GET_BAUD_RATE: 
LD 

CALL 

CALL 

CP 

JP 

LD 

EDIT_BAUD_RATE: 
SUB 
CP 
JP 
CP 
JP 
LD 


DE,INIT_MSG 

PRINT_STRING 


;Give intro screen 


DE,BAUD_PROMPT ;Ask for baudrate value 

PRINT_STRING 

GET_BDOS_KEYPRESS 

CR ;RETURN only? 

NZ,EDIT_BAUD_RATE ;No, look at keypress 

A,*6* ;Yes, use default value 


*0* ;Make into binary 0-9 

NUL ;Legal choice? 

C,GET_BAUD_RATE ;No, try again 
LF 

NC,GET_BAUD_RATE ;Likewise no, try again 
(BAUD_RATE),A ;Yes, save it as binary value 


GET_PARITY_CHOICE: 

LD DE,PARITY_PROMPT ;Give him parity choices 

CALL PRINT.STRING 

CALL GET_BDOSJ<EYPRESS ;Get his response 

CP CR ;RETURN only? 

JP NZ,EDIT_PARITY_VALUE ;No, edit it 

LD A,*N* ;Yes, use default 

EDIT_PARITY_VALUE: 

CP *E* ;Even parity? 

JP Z,PARITY_IS_LEGAL ;Yes, legal 

CP *0’ ;0dd parity? 

JP Z,PARITY_IS_LEGAL ;Yes, legal 

CP *N* ;No parity? 

JP Z,PARITY_IS_LEGAL ;Yes, legal 

JP GET_PARITY_CH0ICE ;Not legal, so ask again 

PARITY_IS_LEGAL: 

LD (PARITY_CH0ICE),A ;Save parity selection as ASCII 

GE T_DAT ABIT S_CH0ICE: 

LD DE,DATABITS_PROMPT ;Give Databits prompt 

CALL PRINT.STRING 

CALL GET_BDOS_KEYPRESS ;Get response 

CP CR ;RETURN only? 

JP NZ,EDIT_DATABITS_VALUE ;No, use it 

LD A,‘8’ ;Yes, use default 

EDIT_DATABITS_VALUE: 

SUB ’0* ;Make into binary 0 thru 8 

CP BEL ;Legal choice? 

JP Z,DATABITS_ARE_LEGAL ;Yes, use it 

CP BS 

JP Z,DATABITS_ARE_LEGAL ;Yes, use it 

JP GET_DATABITS_CHOICE ;No, try again 


DATABITS_ARE_LEGAL: 

LD (DATABITS),A 


;Save binary databits value 


Now convert baudrate choice to binary timer value 

;19.2 Kbaud? 


LD 

CP 


A,(BAUD_RATE) 

NUL 


(continued) 
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JP NZ,TRY_9600_BAUD ;No 

LO A,SI ;Yes, use timer value for 19.2 Kbaud 

JP DONE_EDITING_BAUD 

TRY_9600_BAUD: 

CP SOH ;9600 baud? 

JP NZ,TRY_4800_BAUD ;No 

LD A,SO ;Yes, use timer value for 9600 baud 

JP DONE_EDITING_BAUD 

TRY_4800_BAUD: 

CP STX ;4800 baud? 

JP NZ.TRY_2400_BAUD ;No 

LD A,FF ;Yes, use timer value for 4800 baud 

JP DONE_EDITING.BAUD 

TRY_2400_BAUD: 

CP ETX ;2400 baud? 

JP NZ,TRY_1200 — BAUD ;No 

LD A,LF ;Yes, use timer value for 2400 baud 

JP DONE_EDITING_BAUD 


TRY_1200_BAUD: 

CP EOT ;1200 baud? 

JP NZ,TRY_600_BAUD ;No 

LD A,BEL ;Yes, use value for 1200 baud 

JP DONE_EDITING_BAUD 


TRY_600_BAUD: 

CP ENQ ;600 baud? 

JP NZ.TRY_300_BAUD ;No 

LD A.ACK ;Yes, use timer value for 600 baud 

JP DONE_EDITING_BAUD 


TRY_300_BAUD: 

CP ACK ;300 baud? 

JP NZ,ASSUME.110_BAUD 

LD A,ENQ ;Yes, use timer value for 300 baud 

JP DONE_EDITING_BAUD 


ASSUME_110_BAUD: 

LD A,STX ;Use timer value for 110 baud 

DONE_EDITING_BAUD: 

LD (BAUD_RATE),A ;Save final timer value for baudrate 


Now convert parity selection to proper control bits 


LD A,(PARITY_CHOICE) 

CP *E* ;Even parity? 

JP NZ.TRY_ODD_PARITY ;No 

LD A,ETX ;Yes, use bit pattern for Even parity 

JP HAVE_GOOD_PARITY_BITMAP 


TRY_ODD_PARITY: 

CP *0’ ;0dd parity? 

JP NZ,ASSUME_NO_PARITY ;No 

LD A,SOH ;Yes, use bit pattern for Odd parity 

J P HAVE_G00D_PARITY_BITMAP 


ASSUME_NO_PARITY: 

LD A.NUL ;Use bit pattern for No parity 

HAVE_G00D_PARITY_BITMAP: 

LD (PARITY_CH0ICE),A ;Save final SIO parity bitmap 


; Edit databits (binary 7 or 8) 

; to create proper SIO bit pattern 

LD A,(DATABITS) 

CP BEL ;7 data bits? 

JP Z,SET_7_DATABIT_PATTERN ;Yes 

LD A,*** ;No, use SIO WR5 pattern for 8 TX databits 

LD (SI0_WR5_TX_BITS).A ;Save to be passed to SIO Write Reg 5 

LD A,’@’+80H -.Format 8 Rx databits for SIO Write Reg 3 
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ID (SI0_WR3_RX_BITS),A 

JP SEND_ALL_TO_S10 


SET_7_DATABIT.PATTERN: 


LD 

A.* • 

;Set bit pattern for 7 Tx 

LD 

(SI0_WR5_TX_BITS),A 

LD 

A. ’«’ 

;Ditto for 7 Rx data bits 

LD 

(SI0_WR3_RX_BITS) ,A 

._TO_SIO: 


> send 

everything to SIO 

DI 



LD 

A .CAN 

;Reset SIO 

OUT 

(IOPORT06H),A 


OUT 

(IOPORT06H),A 


LD 

A, SOH 

;Select SIO Write Reg 1 

OUT 

(IOPORT06H),A 

XOR 

A 

;No SIO interrupts 

OUT 

(IOPORT06H),A 

LD 

A. EOT 

;Se1ect SIO Write Reg 4 

OUT 

(IOPORT06H),A 

LD 

A,(PARITY_CHOICE) ;Get parity bit pattern 

ADD 

A. ‘D’ 

;Add 'Clock x 16’ and *1 ! 

OUT 

(IOPORT06H),A 


LD 

A.ETX 

;Select SIO Write Reg 3 

OUT 

(IOPORT06H),A 

LD 

A,(SI0_WR3_RX_BITS) 

ADD 

A, SOH 

;Enable Receiver 

OUT 

(IOPORT06H),A 


LD 

A.ENQ 

;Select SIO Write Reg 5 

OUT 

(IOPORT06H),A 

LD 

A,(SI0_WR5_TX_ 

.BITS) 

ADD 

A.LF+80H 

;Add ’DTR' and *Tx Enable 

OUT 

(IOPORT06H),A 


LD 

A, ’G’ 

;Reset Baud Rate generato 

OUT 

(IOPORT00H),A 

LD 

A.(BAUD.RATE) 

;Set our Baud Rate timer ' 

OUT 

(IOPORT00H),A 


El 



LD 

DE.WRAPUP MSG 

;Te11 him that we’re done 

CALL 

RET 

PRINT.STRING 

;Back to CP/M 


’RTS * 


GET_BD0S^KEYPRESS: 


Return next keypress as Uppercase char in A-reg 
LD C,SOH 

CALL BOOS ;Use BDOS to get next keypress 

CP ;Is it lowercase char? 

RET C ;No, return it as-ls 

SUB • * ;Yes, convert to uppercase 

RET 


PRINT_STRING: 


Print $-terminated string at (DE) 


LD 

JP 

INIT.MSG: 

DB 

DB 

DB 

DB 


C.TAB 

BDOS 

SUB," INIT 1.0 for Xerox 820",CR,LF,LF,LF,CR,LF 
"Baud Rates:",CR,LF,"19200 - 0 M ,CR,LF,"9600 
" 1 M ,CR,LF,”4800 - 2",CR,LF,"2400 - 3\CR,LF 

"1200 - 4\CR,LF, M 600 - 5",CR,LF," 300 - 6" 


(i continued ) 
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OB CR.LF," 110 - 7",CR,LF,"$" 


BAUD_PROMPT: 
DB 

DB 


CR,LF,"SeIect baud rate 


(1-9): 6" ,BS 


PARITY_PROMPT: 

DB CR,LF,“SeIect parity (Odd, Even, None): N",BS 

DB M $ M 


DATABITS_PROMPT: 
DB 

DB 


CR,LF,"SeIect word length 


(7 or 8): 8",BS 


WRAPUP_MSG: 

DB CR,LF,"Communicat Ions port set.$" 


BAUD.RATE: 

DB NUL 


DATABITS: 

DB NUL 


PARITY.CHOICE: 

DB NUL 


SIO_WR5_TX_BITS: 

DB NUL 


SI0_WR3_RX_BITS: 

DB NUL,NUL,NUL,NUL,NUL 


820INIT.CTL 

"280MU," by Robert A. Baumann, October 1986, page 203. 


0000LIOPORT00H 

0005LBDOS 

0006LIOPORT06H 

01001 

0100LSTARTUP 
0100CGive intro screen 
0106LGET_BAUD_RATE 
0106CAsk for baudrate value 
010FCRETURN only? 

0111CNo, look at keypress 
0114CYes, use default value 
0116LEDIT_BAUD_RATE 
0116CMake into binary 0-9 
0118CLegal choice? 

011ACNo, try again 
011FCLikewise no, try again 
0122CYes, save It as binary value 
0125LGET_PARITY_CHOICE 
0125CGive him parity choices 
012BCGet his response 
012ECRETURN only? 

0130CNo, edit it 
0133CYes, use default 
0135LEDIT_PARITY_VALUE 
0135CEven parity? 
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0137CYes, legal 
013ACOdd parity? 

013CCYes, legal 
013FCNo parity? 

0141CYes, legal 

0144CNot legal, so ask again 

0147LPARITY_IS_LEGAL 

0147CSave parity selection as ASCII 

014ALGET_DATABITS_CHOICE 

014ACGive Databits prompt 

0150CGet response 

0153CRETURN only? 

0155CNo, use it 
0158CYes, use default 
015ALEDIT_DATABITS_VALUE 
015ACMake into binary 0 thru 8 
015CCLegal choice? 

015ECYes, use it 
0163CYes, use it 
0166CNo, try again 
0169LDATABITS_ARE_LEGAL 
0169C$ave binary databits value 

016CC\nNow convert baudrate choice to binary timer value 
016FC19.2 Kbaud? 

0171CNo 

0174CYes, use timer value for 19.2 Kbaud 

0179LTRY_9600_BAUD 

0179C9600 baud? 

017BCNO 


017ECYes, use timer 
0183LTRY_4800_BAUD 
0183C4800 baud? 
0185CNO 

0188CYes, use timer 
018DLTRY_2400_BAUD 
018DC2400 baud? 
018FCNO 

0192CYes, use timer 
0197LTRY_1200_BAUD 
0197C1200 baud? 
0199CNO 

019CCYes, use value 
01A1LTRY_600_BAUD 
01A1C600 baud? 
01A3CNO 

01A6CYes, use timer 
01ABLTRY_300_BAUD 
01ABC300 baud? 


value for 9600 baud 


value for 4800 baud 


value for 2400 baud 


for 1200 baud 


value for 600 baud 


01B0CYes, use timer value for 300 baud 

01B5LASSUME.110.BAUD 

01B5CUse timer value for 110 baud 


01B7LD0NE_EDITING.BAUD 

01B7CSave final timer value for baudrate 

01BAC\nNow convert parity selection to proper control bits 

01BDCEven parity? 

01BFCNo 

01C2CYes, use bit pattern for Even parity 
01C7LTRY_0DD_PARITY 
01C7COdd parity? 

01C9CNO 


01CCCYes, use bit pattern for Odd parity 
01D1LASSUME_NO_PARITY 
01D1CUse bit pattern for No parity 
01D3LHAVE_G00D_PARITY_BITMAP 
01D3CSave final SIO parity bitmap 

01D6C\nEdit databits (binary 7 or 8) \nto create proper SIO bit pattern 
01D9C7 data bits? 

01DBCYes 

01DECNo, use SIO WR5 pattern for 8 TX databits 
01E0CSave to be passed to SIO Write Reg 5 
01E3CFormat 8 Rx databits for SIO Write Reg 3 
01EBLSET_7_DATABIT_PATTERN 
01EBCSet bit pattern for 7 Tx bits 
01F0CDitto for 7 Rx data bits 
01F5LSEND_ALL_TO_SIO 


[continued) 
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01F5C\nOK, so send everything to SIO 

01F6CReset SIO 

01FCCSeIect SIO Write Reg 1 

0200CNo SIO interrupts 

0203CSeIect SIO Write Reg 4 

0207CGet parity bit pattern 

020ACAdd 'Clock x 16* and '1 stop bit' pattern 

020ECSeIect SIO Write Reg 3 

0215CEnable Receiver 

0219CSeIect SIO Write Reg 5 

0220CAdd ’DTR’ and 'Tx Enable' and 'RTS' 

0224CReset Baud Rate generator 
0228CSet our Baud Rate timer value 
022ECTell him that we're done 
0234CBack to CP/M 
02351 

0235LGET_BDOSJ<EYPRESS 

0235C\nReturn next keypress as Uppercase char In A-reg 
0237CUse BDOS to get next keypress 
023ACIs it lowercase char? 

023CCNO, return it as-is 
023DCYes, convert to uppercase 
02401 

0240LPRINT.STRING 

0240C\nPrlnt $-terminated string at (DE) 

0245B 

0245LINIT_MSG 

02C8LBAUD_PROMPT 

02EFLPARITY_PROMPT 

0316LDATABITS_PROMPT 

033DLWRAPUP_MSG 

0358B 

0358LBAUD_RATE 

0359B 

0359LDATABITS 

035AB 

035ALPARITY_CHOICE 
035BLSIO__WR5_TX_BITS 
035CLSIO_WR3_RX_BITS 


820INIT.PRN 

"Z80MU," by Robert A. Baumann, October 1986, page 203. 


MACRO-80 3.43 27-Jul-81 


PAGE 


. Z80 

ORG 00100H 


;This source is for M80.COM! 


Equates for ASCII control chars 


0000 

0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

000A 

000B 

000C 

000D 

000E 

000F 

0010 


NUL EQU 000H 

SOH EQU 001H 

STX EQU 002H 

ETX EQU 003H 

EOT EQU 004H 

ENQ EQU 005H 

ACK EQU 006H 

BEL EQU 007H 

BS EQU 008H 

TAB EQU 009H 

LF EQU 00AH 

VT EQU 00BH 

FF EQU 00CH 

CR EQU 00DH 

50 EQU 00EH 

51 EQU 00FH 

DLE EQU 010H 
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0011 

XON 

EQU 

011H 

0012 

DC 2 

EQU 

012H 

0013 

XOFF 

EQU 

013H 

0014 

DC 4 

EQU 

014H 

0015 

NAK 

EQU 

015H 

0016 

SYN 

EQU 

016H 

0017 

ETB 

EQU 

017H 

0018 

CAN 

EQU 

018H 

0019 

EM 

EQU 

019H 

001A 

SUB 

EQU 

01 AH 

001B 

ESC 

EQU 

01BH 

001C 

FS 

EQU 

01CH 

001D 

GS 

EQU 

01DH 

001E 

RS 

EQU 

01EH 

001F 

US 

EQU 

01FH 


> 

• 

* 

Externa 

1 ref equates 

0000 

IOPORT00H 

EQU 00000H 

0005 

BDOS 

EQU 

00005H 

0006 

IOPORT06H 

EQU 00006H 


• 

• 

• 

End of 

external equates 


0100’ STARTUP: 


0100' 

11 

0245' 

LD 

DE,INIT_MSG *,Give Intro screen 


MACRO-80 3.43 

27-Ju1-81 PAGE 

1-1 

0103' 

CD 

0240' 

CALL 

PRINT_STRING 

0106' 



GET_BAUD_RATE: 


0106' 

11 

02C8' 

LD 

DE,BAUD_PROMPT ;Ask for baudrate value 

0109' 

CD 

0240' 

CALL 

PRINT_STRING 

010C' 

CD 

0235' 

CALL 

GET_BDOS_KEYPRESS 

010F' 

FE 

0D 

CP 

CR ;RETURN only? 

0111' 

C2 

0116* 

JP 

NZ,EDIT_BAUD_RATE ;No, look at keypress 

0114' 

3E 

36 

LD 

A,'6' ;Yes, use default value 

0116' 



EDIT_BAUD_RATE: 


0116' 

D6 

30 

SUB 

'0' ;Make into binary 0-9 

0118' 

FE 

00 

CP 

NUL ;Legal choice? 

011 A* 

DA 

0106' 

JP 

C,GET_BAUD_RATE ;No, try again 

01 ID' 

FE 

0A 

CP 

LF 

01 IF' 

D2 

0106’ 

JP 

NC,GET_BAUD_RATE ;Likewise no, try again 

0122* 

32 

0358' 

LD 

(BAUD_RATE),A ;Yes, save It as binary value 

0125' 



GET_PARITY_CHOICE: 

0125' 

11 

02EF' 

LD 

DE,PARITY_PROMPT ;Give him parity choices 

0128' 

CD 

0240’ 

CALL 

PRINT_STRING 

012B' 

CD 

0235’ 

CALL 

GET_BDOS_KEYPRESS ;Get his response 

012E' 

FE 

0D 

CP 

CR ;RETURN only? 

0130' 

C2 

0135' 

JP 

NZ,EDIT_PARITY_VALUE ;No, edit it 

0133' 

3E 

4E 

LD 

A,'N’ ;Yes, use default 

0135* 



EDIT_PARITY_VALUE: 

0135' 

FE 

45 

CP 

*E* ;Even parity? 

0137' 

CA 

0147' 

JP 

Z,PARITY_IS_LEGAL ;Yes, legal 

013A* 

FE 

4F 

CP 

'O' ;Odd parity? 

013C' 

CA 

0147' 

JP 

Z,PARITY_ISJ.EGAL ;Yes, legal 

013F' 

FE 

4E 

CP 

'N' ;No parity? 

0141' 

CA 

0147' 

JP 

Z,PARITY_IS_LEGAL ;Yes, legal 

0144' 

C3 

0125’ 

JP 

GET_PARITY_CHOICE ;Not legal, so ask again 

0147' 



PARITY_IS_LEGAL 

. 

0147' 

32 

035A* 

LD 

(PARITY_CHOICE).A ;Save parity selection as ASCII 

014A ’ 



GET.DATABITS.CHOICE: 

014A’ 

11 

0316' 

LD 

DE,DATA8ITS_PR0MPT ;Give Dotoblt# prompt 


(continued) 
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014D* 

CD 

0240* 

0150’ 

CD 

0235’ 

0153’ 

FE 

0D 

0155’ 

C2 

015A’ 

0158’ 

3E 

38 

015A* 

015A* 

D6 

30 

015C* 

FE 

07 

015E ’ 

CA 

0169’ 

0161 ’ 

FE 

08 

0163’ 

CA 

0169’ 

0166* 

C3 

014A ’ 

0169’ 

0169’ 

32 

0359’ 


CALL PRINT.STRING 

CALL GET.BDOS.KEYPRESS ;Get response 

CP CR ;RETURN only? 

JP NZ.EDIT.DATABITS.VALUE ;No, use It 

LD A, ’8* ;Yes, use default 


EDIT.DATABITS.VALUE: 


SUB 

CP 

JP 

CP 

JP 

JP 


;Make Into binary 0 thru 8 
BEL ;Legal choice? 

Z,DATABITS.ARE.LEGAL ;Yes, use it 
BS 

Z,DATABITS.ARE.LEGAL ;Yes, use It 
CET.DATABITS_CHOICE ;No, try again 


DATABITS_ARE_LEGAL: 

LD (DATABITS),A 


;Save binary databits value 
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016C * 
016F ’ 
0171* 
0174* 
0176’ 

0179* 
0179* 
017B * 
017E * 
0180’ 

0183’ 

0183’ 

0185’ 

0188’ 

018A’ 

018D ’ 
018D ’ 
018F ’ 
0192’ 
0194’ 

0197’ 
0197’ 
0199* 
019C’ 
019E ’ 

01A1 ’ 
01A1 ’ 
01 A3 ’ 
01A6 * 
01A8 ’ 

01AB ’ 
01AB ’ 
01 AD* 
01B0’ 
01B2 ’ 

01B5 ’ 
01B5 ’ 

01B7 ’ 
01B7 ’ 


3A 0358’ 
FE 00 
C2 0179’ 
3E 0F 
C3 01B7 * 


FE 01 
C2 0183’ 
3E 0E 
C3 01B7’ 


FE 02 
C2 018D‘ 
3E 0C 
C3 01B7’ 


FE 03 
C2 0197* 
3E 0A 
C3 01B7* 


FE 04 
C2 01A1* 
3E 07 
C3 01B7* 


FE 05 
C2 01AB’ 
3E 06 
C3 01B7’ 


FE 06 
C2 01B5’ 
3E 05 
C3 01B7’ 


3E 02 

32 0358’ 


Now convert baudrate choice to binary timer value 


LD 

CP 

JP 

LD 

JP 

TRY.9600.BAUD: 
CP 
JP 
LD 
JP 

TRY.4800.BAUD: 
CP 
JP 
LD 
JP 

TRY.2400.BAUD: 
CP 
JP 
LD 
JP 

TRY_1200.BAUD: 
CP 
JP 
LD 
JP 

TRY.600.BAUD: 

CP 

JP 

LD 

JP 

TRY.300.BAUD: 
CP 
JP 
LD 
JP 


A.(BAUD.RATE) 

NUL ;19.2 Kbaud? 

NZ.TRY_9600.BAUD ;No 

A » S i ;Yes » use timer value for 19.2 Kbaud 

DONE.E DITING.BAUD 


SOH ;9600 baud? 

NZ.TRY_4800.BAUD ;No 

A ’ S0 IYes, use timer value for 9600 baud 

DONE.EDITING.BAUD 


STX ;4800 baud? 

NZ.TRY_2400.BAUD ;No 

A » FF IYes. use timer value for 4800 baud 

DONE.EDITING.BAUD 


ETX ;2400 baud? 

NZ.TRY_1200.BAUD ;No 

A ’ LF »* Yes, use timer value for 2400 baud 

DONE.EDITING.BAUD 


EOT ;1200 baud? 

NZ.TRY_600.BAUD ;No 

A * BF L ;Yes. use value for 1200 baud 

DONE.EDITING.BAUD 


ENQ ;600 baud? 

NZ.TRY_300.BAUD ;No 

;Yes » use tlmer value for 600 baud 
DONE.EDITING.BAUD 


ACK ;300 baud? 

NZ,ASSUME.110.BAUD 

A » EN C IYes. use timer value for 300 baud 

DONE.EDITING.BAUD 


ASSUME.110.BAUD: 

LD A.STX 


I Use timer value for 110 baud 


01 BA’ 3A 035A’ 
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LD (BAUD.RATE),A ;Save final timer value for baudrate 
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LD A,(PARITY.CHOICE) 
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01BD * 

FE 45 

CP 

*E* ;Even parity? 

01BF * 

C2 01C7 * 

JP 

NZ,TRY_ODD_PARITY ;No 

01C2 * 

3E 03 

LD 

A.ETX ;Yes, use bit pattern for Even parity 

01C4* 

C3 01D3 * 

JP 

HAVE_GOOD_PARITY_BITMAP 

01C7 * 


TRY ODD PARITY: 


01C7 * 

FE 4F 

CP 

*0* ;Odd parity? 

01C9 * 

C2 01D1* 

JP 

NZ,ASSUME_NO_PARITY ;No 

01CC’ 

3E 01 

LD 

A.SOH ;Yes, use bit pattern for Odd parity 

01CE * 

C3 01D3* 

JP 

HAVE_GOOD_PARITY_BITMAP 

01D1 * 


ASSUME_NO_PARITY: 

01D1 * 

3E 00 

LD 

A.NUL ;Use bit pattern for No parity 

01D3 * 


HAVE GOOD_PARITY_BITMAP: 

01D3* 

32 035A* 

LD 

(PARITY_CHOICE),A ;Sove final SIO parity bitmap 



; Edit databits 

(binary 7 or 8) 



; to create proper SIO bit pattern 

01D6 ’ 

3A 0359’ 

LD 

A,(DATABITS) 

01D9 ’ 

FE 07 

CP 

BEL ;7 data bits? 

01DB * 

CA 01EB * 

JP 

Z,SET_7_DATABIT_PATTERN ;Yes 

01DE ’ 

3E 60 

LD 

A,*** ;No, use SIO WR5 pattern for 8 TX databits 

01E0’ 

32 035B * 

LD 

(SI0_WR5_TX_BITS),A ;Save to be passed to SIO Write Reg 5 

01E3 * 

3E C0 

LD 

A,+80H ;Format 8 Rx databits for SIO Write Reg 3 

01E5 * 

32 035C* 

LD 

(SI0_WR3_RX_BITS),A 

01E8 ’ 

C3 01F5* 

JP 

SEND__ALL_TO_SIO 

01EB * 


SET_7_DATABIT_PATTERN: 

01EB * 

3E 20 

LD 

A,’ ’ ;Set bit pattern for 7 Tx bits 

01ED * 

32 035B* 

LD 

(SI0_WR5JTX_BITS),A 

01F0 ’ 

3E 40 

LD 

A,;Ditto for 7 Rx data bits 

01F2 * 

32 035C * 

LD 

(SI0_WR3__RX_BITS) , A 

01F5* 


SEND_ALL_TO_SIO 

: 


01F5 1 
01F6* 
01F8 ’ 
01FA* 
01FC * 
01FE * 
0200 ’ 
0201 * 
0203’ 
0205’ 
0207’ 
020A’ 


F3 

3E 18 
03 06 
D3 06 
3E 01 
03 06 
AF 

D3 06 
3E 04 
D3 06 
3A 035A’ 
C6 44 


OK, so send everything to SIO 


01 

LD 

OUT 

OUT 

LD 

OUT 

XOR 

OUT 

LD 

OUT 

LD 

ADD 


;Reset SIO 


A, CAN 

(IOPORT06H),A 
(IOPORT06H),A 
A,SOH 

(IOPORT06H),A 
A 

(IOPORT06H),A 
A, EOT 

(IOPORT06H),A 
A,(PARITY_CHOICE) ;Get parity bit pattern 
A, *D* ;Add 'Clock x 16’ and *1 stop bit* pattern 


;SeIect SIO Wr1te Reg 1 

;No SIO interrupts 

;SeIect SIO Write Reg 4 


020C ’ 

D3 06 

OUT 

(IOPORT06H),A 


020E * 

3E 03 

LD 

A,ETX 

;Se 1 

ect SIO Write Reg 3 

0210 ’ 

D3 06 

OUT 

(IOPORT06H),A 
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0212* 

3A 035C * 


LD 

A.(SI0_WR3_RX_BITS) 

0215* 

C6 01 


ADD 

A.SOH 

;Enable Receiver 

0217* 

D3 06 


OUT 

(IOPORT06H),A 


0219* 

3E 05 


LD 

A.ENQ 

;Se1ect SIO Write Reg 5 

021B * 

D3 06 


OUT 

(IOPORT06H),A 


021D* 

3A 035B * 


LD 

A,(SI0_WR5_TX_BITS) 

0220* 

C6 8A 


ADD 

A.LF+80H 

;Add *DTR’ and *Tx Enable* ( 

0222’ 

D3 06 


OUT 

(IOPORT06H),A 


0224* 

3E 47 


LD 

A, 'G' 

;Reset Baud Rate generator 

0226* 

D3 00 


OUT 

(IOPORT00H),A 


0228* 

3A 0358’ 


LD 

A.(BAU0_RATE) 

;Set our Baud Rate timer va 

022B * 

D3 00 


OUT 

(IOPORT00H),A 
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0220 * 

FB 


El 


022E ’ 

11 

0330* 

LD 

DE,WRAPUP_MSG ;Te11 him that we*re done 

0231 * 

CD 

0240' 

CALL 

PRINT_STRING 

0234 * 

C9 


RET 

;Back to CP/M 

0235 * 



GET_BD0S.KEYPRESS: 




9 

; Return next 

keypress as Uppercase char in A-reg 

0235* 

0E 

01 

LD 

C,SOH 

0237* 

CD 

0005 

CALL 

BOOS ;Use BOOS to get next keypress 

023A ’ 

FE 

60 

CP 

*** ;I8 It lowercase char? 

023C* 

D8 


RET 

C ;No, return it as-ls 

023D* 

D6 

20 

SUB 

;Yes, convert to uppercase 

023F * 

C9 


RET 


0240* 



PRINT_STRING: 





* 

; Print $-terminoted string at (DE) 

0240' 

0E 

09 

LD 

C.TAB 

0242* 

C3 

0005 

JP 

BDOS 

0245* 



INIT.MSG: 


0245* 

1A 

49 4E 49 

OB 

SUB,"INIT 1.0 for Xerox 820",CR,LF,LF,LF,CR,LF 

0249* 

54 

20 31 2E 



0240* 

30 

20 66 6F 



0251 * 

72 

20 58 65 



0255* 

72 

6F 78 20 



0259* 

38 

32 30 00 



0250* 

0A 

0A 0A 0D 



0261* 

0A 




0262* 

42 

61 75 64 

DB 

“Boud Rates:",CR.LF,"19200 = 0".CR.LF,"9600 - 

0266* 

20 

52 61 74 



026A* 

65 

73 3A 0D 



026E * 

0A 

31 39 32 



0272* 

30 

30 20 30 



0276* 

20 

30 00 0A 



027A * 

39 

36 30 30 



027E * 

20 

20 30 
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0281 * 

20 

31 0D 0A 

OB 

" 1 ". CR.LF,"4800 - 2",CR.LF,"2400 - 3",CR.LF 

0285* 

34 

38 30 30 



0289* 

20 

20 3D 20 



028D * 

32 

0D 0A 32 



0291* 

34 

30 30 20 



0295* 

20 

3D 20 33 



0299* 

00 

0A 



029B * 

31 

32 30 30 

DB 

"1200 - 4",CR.LF," 600 - 5",CR.LF," 300 - 6' 

029F * 

20 

20 3D 20 



02A3 * 

34 

00 0A 20 



02A7 * 

36 

30 30 20 



02AB * 

20 

30 20 35 



02AF * 

00 

0A 20 33 



02B3 * 

30 

30 20 20 



02B7 * 

3D 

20 36 



02BA* 

00 

0A 20 31 

DB 

CR.LF," 110 - 7".CR.LF,“$" 

02BE * 

31 

30 20 20 



02C2 * 

30 

20 37 00 



02C6 * 

0A 

24 



02C8 * 



BAUD_PROMPT: 


02C8 * 

0D 

0A 53 65 

OB 

CR.LF,"Select baud rote (1-9): 6",BS 

02CC* 

6C 

65 63 74 



02D0 * 

20 

62 61 75 



02D4* 

64 

20 72 61 



02D8* 

74 

65 20 20 
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02DC' 
02E0 * 
02E4 * 
02E8 * 
02EC * 


20 20 20 20 
20 20 20 20 
20 28 31 2D 
39 29 3A 20 
36 08 


02EE * 24 


DB "$" 


02EF * 



PARITY.PROMPT: 


02EF • 

0D 0A 53 

65 

DB CR.LF,"Select 

parity 

02F3 ’ 

6C 65 63 

74 



02F7’ 

20 70 61 

72 



02FB * 

69 74 79 

20 



02FF * 

20 28 4F 

64 



0303 * 

64 2C 20 

45 



0307 * 

76 65 6E 

2C 



030B* 

20 4E 6F 

6E 



030F * 

65 29 3A 

20 



0313 * 

4E 08 




0315' 

24 


DB "$" 


0316* 



DATABITS_PROMPT: 


0316’ 

0D 0A 53 

65 

DB CR.LF,"Select 

word lei 

031 A' 

6C 65 63 

74 
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031E * 

20 77 6F 

72 



0322’ 

64 20 6C 

65 



0326’ 

6E 67 74 

68 



032A* 

20 20 20 

20 



032E ’ 

20 20 28 

37 



0332’ 

20 6F 72 

20 



0336’ 

38 29 3A 

20 



033A’ 

38 08 




033C* 

24 


DB "$" 


033D' 



WRAPUP_MSG: 


033D ’ 

00 0A 43 

6F 

DB CR.LF,"Communicotions 

0341’ 

6D 6D 75 

6E 



0345’ 

69 63 61 

74 



0349’ 

69 6F 6E 

73 



034D ’ 

20 70 6F 

72 



0351’ 

74 20 73 

65 



0355’ 

74 2E 24 




0358’ 



BAUD_RATE: 


0358’ 

00 


DB NUL 


0359’ 



DATABITS: 


0359’ 

00 


DB NUL 


035A’ 



PARITY_CHOICE: 


035A’ 

00 


DB NUL 


035B * 



SI0_WR5_TX_BITS: 


035B ’ 

00 


DB NUL 


035C ’ 



SIO_WR3_RX_BITS: 


035C ’ 

00 00 00 

i 00 

DB NUL,NUL,NUL,NUL,NUL 

0360’ 

00 





(7 or 8): 8\BS 


(continued) 
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Macros: 


SymboIs: 


0006 

ACK 

01B5* 

ASSUME.110.BAUD 

01D1 * 

ASSUME_NO_PARITY 

02C8' 

BAUD.PROMPT 

0358' 

BAUD.RATE 

0005 

BDOS 

0007 

BEL 

0008 

BS 

0018 

CAN 

000D 

CR 

0359' 

DATABITS 

0169' 

DAT ABITS_ARE_LEG 

0316' 

DAT ABITS.PROMPT 

0012 

DC 2 

0014 

DC 4 

0010 

DLE 

01B7' 

DONE.EDITING.BAU 0116' 

EDIT_BAUD_RATE 

015A' 

EDIT_DATABITS_VA 0135' 

EDIT_PARITY.VALU 0019 

EM 

0005 

ENQ 

0004 

EOT 

001B 

ESC 

0017 

ETB 

0003 

ETX 

000C 

FF 

001C 

FS 

0106* 

GET_BAUD_RATE 

0235* 

GET_BDOS_KEYPRES 

014A* 

GET_DATABITS_CH0 0125' 

GET.PARITY_CH0IC 001D 

GS 

01D3' 

HAVE_GOOD_PARITY 0245' 

INIT.MSG 

0000 

IOPORT00H 

0006 

IOPORT06H 

000A 

LF 

0015 

NAK 

0000 

NUL 

035A* 

PARITY.CHOICE 

0147’ 

PARITY_IS.LEGAL 

02EF' 

PARITY.PROMPT 

0240* 

PRINT.STRING 

00 IE 

RS 

01F5' 

SEND_ALL_T0_SI0 

01EB * 

SET_7.DATABIT_PA 000F 

SI 

035C' 

SI0_.WR3_RX.BITS 

035B' 

SI0_WR5_TX_BITS 

000E 

SO 

0001 

SOH 

0100* 

STARTUP 

0002 

STX 

001A 

SUB 

0016 

SYN 

0009 

TAB 

0197* 

TRY_1200.BAUD 

018D* 

TRY.2400 BAUD 

01 AB * 

TRY_300_BAUD 

0183* 

TRY_4800_BAUD 

01A1 * 

TRY_600_BAUD 

0179* 

TRY_9600_BAUD 

01C7' 

TRY.ODD PARITY 

00 IF 

US 

000B 

VT 

033D' 

WRAPUP.MSG 

0013 

XOFF 

0011 

XON 


No Fatal error(s) 


PATCHES.DOC 


"Z80MU,"by Robert A. Baumann, October 1986, page 203. 


*++++**++++++*++++++*+++++++++++#++*+*+ 

* PATCHES to Z80MU.EXE version 3.10 * 

*************************************** 

Development of the public-domain version of Z80MU has been stopped. 
We are putting all of our energies into the new, commercial version 
which is Z80MU version 5.00 (NEC v20 support, windows, etc). 

As a result, there will be no more source changes to version 3.10. 
Instead, fixes will take the form of patches. Things which cannot be 
fixed via patches simply won't be fixed for version 3.10, but WILL 
show up (fixed) in the new version 5.00. 

Your copy of Z80MU.EXE may already have one or more of these patches 
applied. Check with DEBUG to be sure. 


Applying Patches: 


Patches described here are applied as follows (against Z80MU.EXE 
version 3.10 ONLY!!!!!): 

rename z80mu.exe foo 
debug foo 

<fixes as described below> 
w 

q 

rename foo z80mu.exe 

These patches already allow for the EXE file offset, so just use 
addresses as given and don't try to second-guess us. 
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PATCH #1: Z80 "RLD" opcode bug (9/1/86) 


There is a bug in the RLD microcoding within the Z80 engine. This 
caused EAC (and perhaps many other programs) to print wrong answers. 
This patch corrects the handling of the RLD opcode. 

ADDRESS OLD VALUE NEW VALUE COMMENTS 


B392 8A 88 change "MOV AH,CL"... 

6893 El C4 ...to "MOV AH,AL" 


Z80MU.DOC 

"Z80MU,"by Robert A. Baumann, October 1986, page 203. 


"Z80MU" Z80 and CP/M 2.2 Emulator User’s Guide 

or 

The Care and Feeding of Your Imaginary Z80 
or 

Fakeware For The Techie Masses! 


A Guide to the Complete Z80 Emulator 
Z80MU.EXE version 3.10 3/14/86 


This document describes Z80MU, a software emulation of the Z80 and CP/M 
2.2. The program was written by Joan Riff for Computerwise Consulting 
Services. 

Placed in the public domain. No copyright notice. No legal mumbo-jumbo. 
No request for a financial contribution. No warrantee. Just a bunch of 
marvelous software magic. 

COMPUTERWISE CONSULTING SERVICES, P.0. BOX 813, MCLEAN, VA 22101 

"Z80MU" Z80 and CP/M 2.2 Emulator User’s Guide Page 1 

INTRODUCTION 


INTRODUCTION 


What is it? 

Z80MU is a software emulator of the ZILOG Z80 processor, which runs on 
the IBM PC. It also provides an emulation of Digital Research’s CP/M 
version 2.2 operating system. 

(continued) 
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It includes the following facilities: 

Complete emulation of Z80 object code, Including all six 
active bits within the Z80 Flags Register. 

Emulation of CP/M 2.2, with the exception of hardware-specific 
functIons. 

Advanced commands for debugging Z80 software (eliminating the 
need for DDT.COM), including: 

Illegal Opcode control (treat 'em as FAULTS or NOPs). 

BDOS function trace. 

Instruction TRACE and NOTRACE, with Z80 PC traceback. 
Breakpoints. 

Dump CP/M memory In HEX and ASCII. 

Patch CP/M memory in HEX, decimal, binary, ASCII charac¬ 
ters, or ASCII strings. 

Symbolic labels may be defined and used instead of CP/M 
addresses. 

"Z80MU" Z80 and CP/M 2.2 Emulator User’s Guide Paae 2 

INTRODUCTION y 


Z80 register and flag display and alter, including 

alternate regs/flags and IFF1, IFF2, IMF, I, R regs. 

CP/M memory move and find. 

Intel HEX files can be properly read into CP/M memory, 
as well as created from CP/M memory. 

An "emulated VT52 terminal" for full-screen CP/M applications. 

A full disassembler much like Ward Christensen's RESOURCE, 
built right in, with: 

Symbolic addresses. 

Control breakpoints for Instructions, Bytes (DB), Words 
(DW), Table of Words (DW), and Storage (DS). 

Automatic label generation. 

Comments associated with Z80 addresses. 


Online help summaries. 

Limited SUBMIT file support (built right in - no need for 
SUBMIT.COM). 

Access to all PCDOS programs and commands. 

CP/M software reads and writes PCDOS files, and can be 

organized with the PCDOS directory structure (instead of 
using CP/M’s "user number" idea). 


Z80MU (from now on called "the Emulator") can be used quite transpar¬ 
ently to run CP/M applications on the IBM PC. It contains many advanced 
commands not found in CP/M, but there’s no law that says that you have 
to use em all. By ignoring the advanced commands, you can run the 
emulated CP/M all day long and you'll swear that you're running CP/M. 

You can also take advantage of the advanced commands and features, and 
have a user interface more powerful than that available with CP/M. 


102 BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 




October 


Advanced Z80 programmers can even ignore CP/M entirely and use the 
Emulator as a generic Z80 development tool for developing device 
controllers and other non-CP/M based Z80 code. 

"Z80MU" Z80 and CP/M 2.2 Emulator User’s Guide Page 3 

INTRODUCTION 


At CCS, we use the Emulator to develop things like Z80-based hard disk 
controller card software, device-switching hardware, and even a few 
boring old standard CP/M applications. We have also used it to regen¬ 
erate the source code for the 32K ROM in the Radio Shack Model 100 
laptop computer, to figure out how it works. 

The Emulator consists of a high-speed 8088 assembler subroutine (which 
does the actual Z80 emulation), and a 'C’-language main program which 
provides the CP/M-1 ike interface to the user, the disassembler, the 
RESOURCE facility, and the rest of the advanced features. 


Whv Did We Do It? 

At CCS, we have quite an investment in CP/M software. Most of that 
software consists of fairly esoteric software development tools, things 
that are hard to find in the IBM PC world. Furthermore, we continue to 
develop software for the Z80. The old chip just won’t die, although 
nowadays it is used more in controller boards than as a primary system 
processor. 

We wanted to keep these Z80 tools, yet apply our numerous IBM PC tools 
(especially some fantastic IBM PC editors) to our Z80 development 
process. 

We were also keenly interested in creating source code for some object- 
only Z80 applications, with a view to converting them to 8088 assembler 
source code for re-assembly as native IBM PC programs. 

We scouted around and discovered several software packages which sup¬ 
posedly allowed us to run CP/M programs on the IBM PC. Needless to say, 
they just couldn’t cut it. The Heath User's Group (HUG) emulator, 80Mate 
by Vertex, and a host of similar packages (both public domain and 
commercial) were considered. There were many things that we were looking 
for, and every cur rent Iy-ava1 IabIe product flunked one or more tests: 

Speed of emulation: some packages performed the actual Z80 
emulation much slower than theoretical calculations said that 
they should have. 

Accuracy of the Emulation: many packages ignored one or more 
of the Z80 flag bits, especially the all-important overflow 
flag. And no available package accurately emulated CP/M’s 
BDOS function calls. Most seemed to simply translate CP/M 
BDOS functions into their PCDOS equivalents, without allowing 
for the many differences in operation between' the similar 
(but not identical) operating system calls. 
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User Interface: some packages didn't even try to provide a 
user environment that looked like CP/M’s CCP. Some, in fact, 
made you re-run their emulator with each CP/M program that you 
wanted to run. 

Special headers 'bound* to programs: some packages required 
you to ’bind' a special header to the front of every CP/M 
.COM file that you wanted to run, and then made you run that 
program straight from PCDOS. 

Debug support and environment control: most of the packages 
assumed that you would use DDT for whatever debugging needed 
to be done. They had nothing built in. And no package provided 
a proper interface to PCDOS commands or to the PCDOS environ¬ 
ment . 

[continued) 
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Since we couldn't trust our software to any available Z80 emulators, we 
started thinking about developing our own. What’s more, we kept bumping 
into folks who were in the business of Z80 development, and who kept 
badgering us to solve this problem "the right way" (whatever that 
means). 

At first, we were skeptical. On the surface, it appeared that a truly 
accurate software emulation of the Z80 would run "hundreds" of times 
slower on an IBM PC than on a real Z80. But then Joan Riff got involved, 
and started playing around with register assignments and a memory model 
that "just might work." By keeping images of most of the Z80 registers 
in 8088 registers (as opposed to memory), and by very careful main¬ 
tenance of the Z80’s flags, Joan was able to hand-code a low-level Z80 
emulator which as far as we can tell is 100% accurate, and only four 
times slower than a 1 Mhz Z80. 

To this basic emulator we added the user interface (written in Lattice 
C) which did all of the control and debug operations that we needed. 

After six man-months of work, we had our Emulator. 
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How Does It Work? 

When it runs under PCDOS, the Emulator looks like this: 

-- 

Z80MU *C* main program 

This is what you talk to, the guy 
that emulates CP/M Console Command 
Processor. 

- + 

Z80 Emulation 8088 Assembler Code 

Which actually emulates the Z80 as 
it "executes" in the CP/M Segment. 


64K CP/M Segment 


In which the Z80 code is 
it executes. The size of 
Transient Program Area is 
bytes. 

held as 
the 

65022 

BDOS and BIOS hooks 


Which trap CP/M BIOS and BDOS 
calls, so that they can be 
emu 1ated. 




The main program accepts the user’s commands, and processes them. When 
and if it comes time to run a Z80 program, the Z80 code is loaded into 
the CP/M Segment, and the 8088 assembler code which actually emulates 
the Z80 is called to run the program there. 

As the Z80 program executes, it accesses the outside world via calls to 
the BDOS and BIOS hooks. The code that is executed for a given BDOS or 
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BIOS function actually resides within the 8088 assembler code that 
emulates the Z80. 


What Does It Require To Run2 

The Emulator runs on the IBM PC under PCDOS 2.x or above. The first 
thing that it does when it runs is allocate 64K to be used as CP/M 
memory (the "CP/M Segment"). Additionally, the various RESOURCE commands 
dynamically allocate memory for labels and comments. A safe rule to use 
is to allow an extra 64K for a large RESOURCE control table. 

In short, if a CHKDSK of your system shows at least 256K free memory 
bytes, then you have enough room to run the Emulator. 


How Accurate an Emulation Is It? 

There are two aspects to the accuracy of the Emulator: 

1) How accurately it emulates the Z80 

2) How accurately it emulates CP/M 2.2 

The Emulator emulates the Z80 almost perfectly, even down to an exact 
emulation of all six flag bits in the Flags Register. Even the untest- 
able Half-carry and Add/Subtract flag bits are emulated. For faster 
execution, the Emulator ignores the two unused bits in the Flags 
Register, so these will not act exactly as they would on a real Z80. 

Input/Output instructions (the IN’s and OUT’s) perform everything except 
the actual strobe of the I/O data lines. You can’t very well have Z80 
code accessing I/O addresses that mean something entirely different on 
the IBM PC. So the actual data transfer has been disabled. But any 
setup, auto-increment of registers, and flag effects have been emulated 
even for the IN’s and OUT’s. 

The Z80 HALT instruction is used as a hook to return control to the main 
*C’ program, and as a call to the emulated CP/M BIOS and BDOS. 

When it came to emulating CP/M 2.2, we took a less precise approach. We 
weren’t interested in emulating the limitations of CP/M. We wanted to 
include many of the benefits of PCDOS. And we wanted to add many more 
"bulltin" commands than were available with CP/M. We also demanded the 
largest possible TPA (Transient Program Area - the amount of memory 
available to be used by a Z80 program). Yet we wanted to keep the 
interface very close to CP/M’s. 
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So we decided to support "standard" CP/M applications, ones that stood a 
good chance of executing on a wide variety of CP/M systems and thus were 
hardware independent. 

This we have succeeded in doing. 

The user interface is just like CP/M’s, so that someone used to CP/M 
will feel right at home. 

The program interface (via the BIOS and BDOS) is exactly the same as 
CP/M’s. There are some BIOS and BDOS functions that are hardware- 
specific, or expect diskettes to have the CP/M format. These are in 
general not supported. The differences are explained in a later section. 
A tremendous omount of work has gone into translating CP/M BDOS func¬ 
tions into their PCDOS equivalents, and back again. Many folks assume 
that a given BDOS function can be emulated simply by calling PCDOS with 
the function in the 8088 AH register. This is not true. On the surface, 
PCDOS functions are similar to CP/M BDOS functions. In fact, there are a 
host of very small but very important differences, which are handled by 
the emulated CP/M within the Emulator. 


(i continued ) 
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The handling of commands and command arguments (the command "tail") 
appears to the Z80 application exactly as it would on a real CP/M 
system. The default FCB at 5Ch is formatted with the filename implied by 
the first command-line argument, and the FCB at 6Ch with the second 
argument. The byte at 80h is set to the number of characters In the 
command tail, and is followed by an uppercase version of the command 
tail as typed by the user. 

We have achieved a TPA size of 65022 bytes. This is more thon is 
available on almost all "real" CP/M systems, including the Baby Blue Z80 
add-on board (for the IBM PC) from MicroLog. 

We have also built a fake VT52 terminal into the Emulator, since 
many CP/M applications (especially those doing full-screen editing) 
assume that they are being run from a serial ASCII terminal. 

All In all, the compatabiIity of the Emulator is so good that we have 
been able to move all of our CP/M applications to the Emulator, and to 
have them run perfectly (although a tad slow). 

Here is a partial list of CP/M applications that we have tested with the 
Emulator and found to run as they do on a "real" CP/M system: 

ASM LOAD ED DDT DUMP 

PIP M80 L80 LIB MBASIC 

LASM MAC dBase II 

WORDSTAR 3.0 & 3.3 with MAILMERGE (but not SPELSTAR!) 
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PMATE-80 rev. 3.02 

Software Toolworks 'C' compiler 

Telecon 'C' compiIer 

Chang Labs' MemoPlan 

LU version 3.00 

S-BASIC Basic compiler v5.4b 

Target PlannerCalc spreadsheet 


This is more a list of the software that we happened to have on hand 
than an exhaustive list of software that will run under the Emulator. 


What WON'T Run Under the E mulator? 

There are some CP/M programs (like STAT.COM provided by Digital Re¬ 
search) which are hardware-specific. These cannot be run under the 
Emulator, or must be run "carefully" to avoid functions that look to the 
hardware. STAT, for instance, starts out by interrogating the physical 
layout of the diskette, and interpreting it as if it were formatted for 
CP/M. Since PCDOS disks aren't in CP/M format, this makes no sense. So 
this is unsupported under the Emulator, and STAT is immediately aborted 
by the Emulator. 

WORDSTAR’S SPELSTAR won't work, either. It tries to call CP/M’s Console 
Command Processor (CCP) within the 64K CP/M segment. In the Emulator, 
however, there is no CCP in the CP/M segment. It’s really quite sad. 
SPELSTAR goes to a lot of work to calculate just where in Z80 memory the 
CCP is located, relative to the BDOS address held in location 0005h. 

Then it calls that address. Unfortunately, there’s nothing there... 

There are some CP/M programs which look too closely at the "reserved" 
fields of the FCB. These may have trouble. We have seen some products 
written by Microsoft which do this. They are thus highly release- 
dependent, and thus ought not to be emulatable at all. We have, however, 
added special code to the Emulator which keeps FCB+14 and FCB+15 
somewhat sensible, and that seems to have allowed these Microsoft 
programs to work. 
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How Fast Is It? 

Aye, there’s the rub. 

Because the Z80 used by the Emulator is an imaginary one whose instruc¬ 
tions must be emulated in software, the effective speed of a Z80 program 
is considerably less than the speed of the IBM PC. One 12-cycle Z80 
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instruction, for example, may take from 47 to over 100 IBM PC cycles 
(depending on the instruction, its addressing mode, etc). 

For detail on the effective speed of the emulated Z80 and what it means, 
see the description of the "speed?” and "howfast?" Builtin Commands 
Iater in this Guide. 

We have not found the speed of the emulated Z80 to be entirely accept¬ 
able. Z80MU is the fastest software-based accurate Z80 emulator that 
we’ve seen for the IBM PC. Yet we would like to have something that 
would run the standard CP/M utilities on an IBM PC at an effective cpu 
speed of at least 1 MegaHertz, and still have all of the subtleties 
(like flag updating) performed with 100% accuracy. 

The solution is to run the Emulator on an IBM PC/AT, Compaq DeskPro 
286, or similarly speedy CPU. 


How Do I Get Mv CP/M-Programs Into The IBM PC? 

Assuming that you want to emulate some CP/M applications on the IBM PC, 
the first realization is that these CP/M files don’t already reside on 
the PC. What’s more, they currently exist (by definition) on disks 
formatted for CP/M, not for the IBM PC. So they can't be read by a 
vanilla IBM PC using PCDOS. They must be copied to standard PCDOS disk 
files. 

We have used several approaches, all with excellent results. 

The first approach is to transfer the CP/M files straight from the CP/M 
disks to PCDOS disks using a utility that runs on the IBM PC and is 
capable of reading the foreign CP/M format. Such utilities include: 

CONVERT (from Selfware, Inc. Fairfax, VA) 

XENOCOPY (from Vertex Systems, Inc. L.A., Calif) 


This approach is nice, when it works. The major disadvantages are: 

Only certain CP/M formats are recognized by each of these 

utilities. Apple ][ and NorthStar Horizon CP/M disks, for 
example, cannot be read on the IBM PC without special 
hardware. 

You must have the CP/M disks at hand. 
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Another approach is to transfer the CP/M files to the IBM PC via a 
communications line. This is Joan Riff’s personal favorite. If the 
CP/M system is at hand, then the two machines are direct-connected and 
cranked up to 9600 baud. If the CP/M system is not handy, then the 
transfer is made over the phone at whatever speeds the respective modems 
can handle. In either case, the CP/M system running BYE and XMODEM is 
controlled by the IBM PC running Crosstalk VI version 3.5 (from Micro- 
Stuf) and Joan Riff’s excellent XMODEM (with CRC) Crosstalk RUN command. 


When direct connected, files really fly across at 9600 baud. 


(continued) 
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The major advantages of this approach are: 

Who cares what the CP/M disk format is? If the CP/M system can 
read its own files, then we can get them. This works very 
well when transferring Apple ][ and NorthStar Horizon 
CP/M files. 

Public Domain CP/M software can be gathered Just by dialing 

into a CP/M Bulletin Board or RCPM system. You need never 
know what hardware system is on the other end. 


CP/M and PCDOS files are similar enough that we have never had to alter 
a file that was transferred using either of the above two approaches. 

We just download the files to the IBM PC and run ’em under the Emulator. 

The biggest problem is remembering which files are PCDOS files and 
which are CP/M files. If you transfer a CP/M file called DUMP.COM, for 
example, from a CP/M system to the IBM PC’s disk, you really do want to 
remember that it is a CP/M file (to be run with the Emulator) and not an 
IBM PC .COM file. If you accidentally Invoke DUMP.COM from PCDOS, you 
will be unpleasantly surprised. The CP/M DUMP.COM file contains Z80 
opcodes, which will be executed by the IBM PC as 8088 opcodes. Time to 
reach for the Big Red Switch... 

You must run such CP/M command (.COM) files under the Emulator! 

At CCS, we keep things straight by storing CP/M files under separate 
PCDOS directories. The "Z80PATH" environment string (explained else¬ 
where) makes this particularly convenient. 

The saving grace to this CP/M-to-PCDOS conversion is that it needs to be 
done only once for a given file. We spent quite a while transferring 10 
megabytes of CP/M files to the IBM PC. But we need never do it again. 

Now we just run everything on the IBM PC. 
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How Do I Run It? . 

The Emulator is just another PCDOS program. There are no arguments to 
give it. There is no syntax. Just type 

Z80MU 

and bingo! - you're in CP/M. 

To make things easier, you may want to copy Z80MU.EXE to one of your 
PCDOS “PATH" directories (if you have any). If you don't have any PATH 
directories set up, then just insert the floppy that holds Z80MU, start 
the program, and then remove the floppy. You don’t need it until you 
want to run the Emulator again. 

The next section ("The PCDOS Environment") describes the PCDOS environ¬ 
ment that applies to the Emulator. You may want to study it before you 
run the thing. 


What Con, G o W rong? 

The Emulator is as safe a program as ever you'll find on the IBM PC. 

You will probably never experience any problem with it. 

There is one important thing to watch out for, however: 

If the Emulator itself is ever aborted, then you should 
immediately reboot your IBM PC. 

Why? Because the Emulator must trap the IBM PC’s BREAK interrupt. When 
the Emulator returns to PCDOS (i.e. - when you type the "exit" command), 
it restores this interrupt the way it was before. If the Emulator never 
gets a chance to exit gracefully, then it never gets a chance to restore 
this interrupt. The thing is left pointing to now-dead code somewhere in 
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the IBM PC's memory. This is bad news for you, and good news for that 
big red switch on the side of your PC... 
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Why might the Emulator abort? Well, there is always the possibility of 
an Emulator bug that we haven’t found. And we're not real confident of 
Lattice C and its flaky subroutine library, which once in a blue moon 
decides to abort for no apparent reason. But the most likely reason is a 
disk error that results in the familiar message: 

Abort. Retry, Ignore? 

If you select Abort, then you’ve just aborted the Emulator and left the 
BREAK interrupt in limbo. So reboot to be safe. 
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THE PCDOS ENVIRONMENT 

The Z80 Emulator runs as a normal application program under PCDOS 
(version 2.0 and above). There are a few things that you should keep in 
mind, in order to get the most out of the Emulator. 


PCDOS’s use of COMMAND.COM 

Certain Emulator commands ("dir", "Ixxxxxx", etc) are handled by calling 
PCDOS to perform the associated operation. The first thing that PCDOS 
does when called in this way is reload its COMMAND.COM file from disk. 

To speed things up, you should make sure that PCDOS’s COMMAND.COM file 
is in a RAMdisk, or on a hard disk. You can tell PCDOS where to find 
COMMAND.COM by using the "SET COMSPEC*" command in your AUTOEXEC.BAT 
file, or the "SHELL" command in your CONFIG.SYS file. 

Certain versions of PCDOS (2.0 and 2.1, and maybe others) have trouble 
obeying the "COMSPEC*" command. They try to reload COMMAND.COM from the 
boot disk, regardless of the current "COMSPEC*" parameter. If you use 
one of these versions of PCDOS, then you may avoid problems by keeping 
COMMAND.COM always available on the boot drive. Alternatively, you may 
apply one of the public domain COMZAP patches to fix your copy of PCDOS. 


The "Z80PATH=" Environment String 

The Emulator has a facility which is equivalent to the PCDOS "PATH" 
command. It allows you to tell the Emulator where to look for Z80 
command (.COM) files. 

This facility is implemented by a new PCDOS environment string, called 
"Z80PATH". This string is a list of fully-qualified names of directories 
which are to be searched when the Emulator is looking for a .COM file to 
load and run. The various directory names must be separated with 
semicolon (";") characters, as follows: 
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SET Z80PATH=c:\cpm;c:\z80\mystuff;c:\ 

This example tells the Emulator to search for Z80 programs first in the 
directory "CPM" on drive C:, and then (if not found there) in the 
directory "Z80\MYSTUFF" on drive C:, and finally (if still not found) in 
the root directory of drive C:. 

A Z80PATH string should be defined in your AUTOEXEC.BAT file, so that 
it is always present when you run the Emulator. 


[continued) 
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The trailing M \" character of each directory name is optional. If it is 
absent, a "\" character is automatically applied to the directory name 
before the name is used in the search. 

The Z80PATH search order is used whenever an "unqualified" program name 
Is used as a command to the Emulator. An "unqualified" program name is a 
legal filename (up to 8 characters) which: 

has no drive ID on the front of it (no character), and 

2) has no directory names imbedded in it (no "\" characters), and 

3) is not the name of an Emulator Builtin Command. 

For example, let’s say that you give the following command to the 
Emu Iator: 

Z80 A>asm dump.aaz 

The Emulator first checks to see if the command ("ASM") is one that it 
recognizes - a so-called Builtin Command (see the "Builtin Commands" 
section). If it is not, then the Emulator acts just like CP/M and 
attaches a .COM extension to the command, yielding "ASM.COM". It then 
looks in the current PCDOS directory on the current disk (in this case, 
drive A:) for a file by the name of ASM.COM. If it finds such a file, 
then it loads it into the CP/M Segment and runs It. 

If the file is not found on the current drive, then the Emulator 
searches the various Z80PATH directories, looking for a file with the 
right name (ASM.COM). The directories are searched In the order that 
they appear in the Z80PATH string. The first ASM.COM file that is found 
is the one loaded and run. 

If there is no Z80PATH string defined in the PCDOS environment, then the 
search stops with the current disk drive’s current PCDOS directory. 

If no matching filename is found after all of this, then the Emulator 
echos the command line 

asm? 
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indicating that it doesn't know what you mean. 

Note that no search takes place if the command is "qualified". A 
"qualified" command includes a drive ID or a pathname, such as: 

Z80 A>b:asm dump.aaz 
Z80 A>\bin\asm dump.aaz 

In such a case, the Emulator tries only once to open the Z80 .COM file, 
using the exact name given. If such a file cannot be found, then the 
command fails as mentioned above. 


The AUTOEXEC.Z80 File 

When the Emulator first starts up. it automatically executes the 
foI I owing command: 

Z80 A>SUBMIT AUTOEXEC.Z80 

If there is no file by the name of AUTOEXEC.Z80 in the current directory 
when the Emulator is run, then an error message is displayed and the 
Emulator Just waits for you to enter commands from the keyboard. 

If there is such a file, however, then the Emulator reads its commands 
from that file, until EOF. See the "submit" builtin command for more 
details about submit files. 

This is an easy way to automate the Emulator. At CCS, we use a different 
AUTOEXEC.Z80 file in each work directory in order to set up the parti¬ 
cular environment that we want to work with. The AUTOEXEC.Z80 file 
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within the Radio Shack Model 100 directory, for example, automatically 
reads in the 64K Model 100 image from disk ("read 0 mode 1100.mem"), and 
the disassembler control file ("control read model 100.ctl H ). It also 
sets up the disassembler format that we want ("list include A 0"). So 
when we start up the Emulator while within that directory, the thing 
comes up ready to do real work. 
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I/Q Redirection With The EmulQtftr. 


NOTE: The "terminal" bull tin command has been enhanced to 
allow internal mapping of the builtin VT52 emulated terminal 
to respond to either CP/M BIOS or CP/M BDOS console I/O 
requests. This may thoroughly confuse the following discus¬ 
sion. So in the following text we assume the default condi¬ 
tion, in which the builtin VT52 terminal emulator only 
responds to CP/M BIOS console I/O requests. 


The Emulator writes its output to the standard output that is defined by 
PCDOS. So regular old PCDOS I/O redirection can be used when you start 
the Emulator. 

For example, the following PCDOS command can be used to run the Emulator 
and capture all Emulator output to file OUTPUT.DOC: 

Z80MU >0UTPUT.DOC 

You may also append output to an existing file with: 

Z80MU »0UTPUT. DOC 

This is perfect for automating the Emulator. Some of the samples 
displayed later in this document were captured by redirecting the 
Emulator’s output to a file, and then editing that file into this 
document. 

There are a few things to bear in mind, however. 

First of all, remember that there are several parts of the Emulator: 


The main program, which reads your commands and in general 
acts like the CP/M CCP. It does all I/O via PCDOS, so it is 
subject to I/O redirection. 

The actual Z80 emulator, which does no I/O at all. 

The CP/M BIOS emulator. It does I/O at the IBM PC ROM BIOS 
level, so PCDOS never sees what's going on. CP/M BIOS terminal 
I/O goes through the emulated "terminal" inside the Emulator, 
and then straight to the IBM PC screen. So I/O redirection 
does not apply there. 

"Z80MU" Z80 and CP/M 2.2 Emulator User's Guide Page 17 

THE PCDOS ENVIRONMENT 


The CP/M BDOS emulator. The BDOS emulator does its I/O via PCDOS, 
so I/O redirection does apply to it, and to any Z80 programs that 
use BDOS functions for I/O. 


Now the question arises: Will my CP/M application obey any I/O redirec¬ 
tion that I specify when I run the Emulator? 

The answer, of course, depends on your application. 

Most "standard" CP/M applications do their I/O via BDOS functions. So 
these will obey your I/O redirection. 


[continued) 
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Full-screen editors, in general, use the BIOS instead of the BDOS, for a 
lot of very good reasons. So these will automatically be exempt from 
your I/O redirection. 


Please remember that all Emulator output is redirected at once. If you 
redirect the output, meaning to enter commands from the keyboard, don’t 
be real surprised if you can’t see any of the Emulator’s prompts. They 
are being written to the redirected output file, and not to the screen. 

NOTE: When you redirect output to a disk file, your Input 
keypresses are supposed to be sent to the output file (not to 
the screen). Some versions of PCDOS, however, contain a bug 
that causes your keypresses to appear on the screen instead. 

We have seen public domain patches to fix this bug floating 
around the Bulletin Boards, but can’t vouch for any of them. 


Using The Keyboard 

The Emulator reads its Input from the standard input as defined by 
PCDOS. So if you don’t use PCDOS input I/O redirection when you start 
the Emulator, then input comes from the keyboard. 

The Emulator could have done its own direct keyboard and screen I/O. 
This would speed things up considerably. PCDOS is notoriously slow when 
it comes to writing to the screen. 

We decided, however, not to circumvent PCDOS when writing to the screen 
and reading from the keyboard. The Emulator is slower as a result. But 
we gain a few conveniences as a result: 

We achieve something closer to true CP/M emulation, 'cause 
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PCDOS automatically handles ~P and ~S/~Q in a manner close to 
CP/M’s handling of them. 

We get automatic I/O redirection. 

We get PCDOS expanding macro keys and interpreting function 
keys. 


The F3 key, for instance, can still be used to repeat the last command 
entered to the Emulator. The ESC key cancels the current Input line. And 
FI recreates the last command one character at a time. Other PCDOS 
keyboard conventions (like Ctr1-NumLock, Ctrl-PrtSc, and so on) are also 
handled by PCDOS in a way that we’re all used to. 

The addition of keyboard enhancers like CED and Sidekick can confuse 
things, so that the function keys don’t act quite right. You’ll just 
have to experiment with it. 

If you want to copy screen output to the printer, then press "P or 
Ctrl-PrtSc. A second press will turn printer echo off. Remember that 
such PCDOS redirection applies to Emulator output (l' k ® dumps, disassem¬ 
blies, etc) as well as to the output of any CP/M applications being run 
under the Emulator that use BDOS functions for output. 

If text is scrolling off of the screen too fast to read (not real 
likely, with PCDOS being as slow as it is), you can pause and restart it 
with ~S/^Q, or Ctr1-NumLock. 

The actions of S/ Q, ‘"‘P and Ctrl—PrtSc may vary, depending on the 
particular CP/M application being run. CP/M’s BDOS function number 6 
(Direct Console I/O), for example, is handled by CP/M without it 
checking for ^S or *P. The Emulator mimics this action. 
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► i lenames! 

CP/M filenames may contain certain characters that PCDOS objects to. In 
general, don't use the "\" or "/" characters in filenames, or the I/O 
redirection characters ">" and and so on. 

And watch out for PCDOS device names that are perfectly innocent 
filenames under CP/M. Things like "CON.ASM" will fool you. 
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THE CP/M ENVIRONMENT 


This section describes the environment set up by the Emulator, under 
which your Z80 programs will run. 


Emulated .Terminal. 


NOTE: The "terminal" builtin command has been enhanced to 
allow internal mapping of the builtin VT52 emulated terminal 
to respond to either CP/M BIOS or CP/M BDOS console I/O 
requests. This may thoroughly confuse the following discus¬ 
sion. So in the following text we assume the default condi¬ 
tion, in which the builtin VT52 terminal emulator only 
responds to CP/M BIOS console I/O requests. 


When a Z80 program does character I/O by calling the emulated CP/M BIOS 
(not using BDOS functions, but BIOS calls), then it is communicating 
with an imaginary, emulated ASCII terminal which is maintained by the 
Emulator. The Emulator interprets ASCII codes that are sent to this 
"terminal", and translates them into appropriate calls to the IBM ROM to 
control the IBM’s display. 

Most ASCII characters that are sent to the emulated "terminal" are 
displayable characters - letters, numbers, and so on. They appear on the 
screen for the user to read. Other ASCII characters - called "control 
sequences" - are used not to display anything, but to cause the "ter¬ 
minal" to perform special functions like clearing the screen, switching 
between high- and Iow-intensity, and so on. 
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The builtin "terminal" obeys VT52 control sequences, which are the 
same ones used by the Heath/Zenith H19 and H89 machines when in ZDS 
mode. They are as follows: 


ESC H Homes cursor 

ESC C Advances cursor 1 char to right. Stays on same line. 

ESC D Backspaces cursor one char to left. Stays on same line. 

ESC B Moves cursor down 1 line, staying in same column. Screen 
Is scrolled if necessary. 

ESC A Moves cursor up 1 line, staying in same column. No 
scrolllng occurs. 

ESC I (uppercase letter "I", HEX 049h) Moves cursor up 1 line, 
staying in same column. Scrolling occurs If cursor was on 
top line. 


(continued) 
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ESC n Causes current cursor position to be returned via 

emulated "keyboard” as ESC Y line# column#. This control 
sequence is i gnored (not suDoor.tedV bv^lhe Emulator 

ESC J Saves cursor position for later restore via ESC k. 

ESC k Returns cursor to position that was saved via ESC J. 

ESC Y line# column# Direct cursor addressing sequence. Screen 
lines are numbered 1 to 25. Screen columns are numbered 1 
to 80. Line# and column# args are obtained by adding 31 
(01Fh) to the desired line or column number. Alternative¬ 
ly, you may think of lines as being numbered from 0 to 
24, columns from 0 to 79, and the offset to add to each 
being 32 (020h). 

To position to line 5. column 10, for example, the 
foI I owing is sent: 

ESC Y $ ) 

which is represented In HEX as 01Bh 059h 024h 029H and In 
decimal as 27 89 36 41. Note that the line# ara is 
obtained by 5 + 31 - 36 (024h), and the column# arg by 10 
+31-41 (029h). 
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Line# or column# aras less than 32 default to 32 (i.e. - 
to line or column 1). An arg value that is too large 
defaults to the max legal value (25 for line, 80 for 
coIumn). 

ESC E Erases the entire screen and homes the cursor. 

ESC b Erases from the start of the screen to the cursor, 
including the cursor position. 

ESC J Erases from the cursor to the end of the screen (inclu¬ 
ding the cursor position). 

ESC I (lowercase letter "L", HEX 06Ch) Erases the entire line 
that the cursor is on, positions the cursor to the left 
edge of that line. 

ESC o (lowercase letter "0". HEX 06Fh) Erases from the 

beginning of the line to the cursor (including the cursor 
position). 

ESC K Erases from the cursor to the end of the line (including 
the cursor position). 

ESC L Inserts a blank line before the line that the cursor is 
on, shifts following lines (Including the cursor line) 
down to make room. Cursor is moved to start of new blank 
line. 

ESC M Deletes the line that the cursor is on, scrolls follow¬ 
ing lines up to fill its place. Cursor moves to left edge 
of its line. 

ESC N Deletes the character under the cursor, shifts remaining 
text to left to cover it up. 

ESC @ (At-sign character, HEX 040h) Enters Insert Mode. 

Displayed characters cause others on the same line to be 
moved right to make room. This can be pretty pokey, 
thanks to the IBM ROM BIOS! 

ESC 0 (uppercase letter "0", HEX 04Fh) Exits Insert Mode. 

ESC p Er. .ers Reverse Video or Highlight mode. 
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ESC q Exits Reverse Video or Highlight mode. 

BEL (decimal 7) Beeps bell. 
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BS (decimal 8) Backspaces cursor one character position. 

HT (decimal 9) Tabs cursor to next mod-8 column boundary 

LF (decimal 10, HEX 0Ah) Advances cursor to next line, same 

coIumn. 

FF (decimal 12, HEX 0Ch) Clears screen and homes cursor. 

CR (decimal 13, HEX 0Dh) Returns cursor to start of current 

line. 


The other standard ASCII control characters (below 032 or 20h) and those 
from 128 (80h) through 255 (FFh) display various graphic symbols. See 
the IBM Tech Ref Manual for details. 

The emulated VT52 "terminal" also translates input from the IBM key¬ 
board. Most keypresses are returned to the Z80 program as single ASCII 
characters. The "extended" codes that are generated by IBM function 
keys, arrow keys, ALT keys, and so on, are translated into 2-byte 
keyboard sequences as follows: 

The first byte is an ESCAPE character (Decimal 027, HEX IBh). 

The second byte is the keyboard scan code, as defined in the 
IBM Tech Ref Manual. 

Additionally, the NUL extended code (CTRL-®) is translated into a 
single ASCII character (Decimal 000). 

For example, assume that the user presses the PgUp key on the IBM 
keyboard. The next time that the Z80 program calls the CP/M BIOS to read 
a keypress from the "terminal", an ESCAPE character will be returned. 

The time after that, a Decimal 073 (HEX 49h) will be returned. This is 
the scan code for the PgUp key. 


The above information may be used to configure particular Z80 applica¬ 
tions for use with the Emulator's "terminal". Remember that this 
emulated "terminal" only appears at the CP/M BIOS interface, unless you 
use the "terminal" command to alter this. Applications that do I/O via 
BDOS functions (which includes most of the standard CP/M utilities) do 
not see this behavior. 
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WORDSTAR, dBase II, Target Plannercalc and PMATE, for example, do at 
least some of their terminal I/O via the CP/M BIOS, so they must be 
configured for the particular terminal being used. Refer to the above 
information when installing such applications for use under the Emula¬ 
tor, using this emulated VT52 "terminal". Please bear in mind, however, 
that things can get very confusing when one application (like dBase II) 
does terminal I/O via both the BIOS and the BDOS. Just experiment until 
you get something useful. 

NOTE: This emulated terminal facility may be controlled vio 
the "terminal" bulltln command, which is described in the 
"BuiItln Commands" section. 


(continued) 
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X and,BREAK Handling 

The X (Ctrl —C) and BREAK (Ctrl-Scroll Lock) keys are handled In a 
special way on the IBM PC. Under normal circumstances, these keypresses 
are trapped by PCDOS and cause the executing PCDOS program (In this 
case, the Emulator) to be aborted. 

This is undesirable. 

Additionally, CP/M includes an important assumption, to wit: X is a 
keypress like any other, and must be passed through all the way to the 
Z80 program for processing. Several standard CP/M programs (PIP.COM, 
M80.COM, WORDSTAR, etc) use X as a command, and must not be aborted 
when It Is typed. 

For this reason, the Emulator traps X and BREAK keypresses. It decides 
what to do with them as follows: 

When not running a Z80 program (i.e. - when the Emulator is 

accepting commands), the BREAK key does nothing and the X 
keypress does various things depending on the mood of PCDOS. 

When executing a Z80 program, pressing X causes a X character 

(Decimal 003) to be queued as keyboard input. Pressing BREAK 
causes the Z80 to be stopped (with an appropriate message), 
and a return to the Emulator awaiting your command. 


When the Emulator stops ("aborts") a Z80 program due to a BREAK key¬ 
press, it displays a message to that effect. It suspends the Z80 in 
perfect order, maintaining all registers, flags, etc. It then accepts 
Emulator commands. 
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At this point you may inspect registers, run another Z80 program, or 
whatever. You may also continue execution of the aborted program with 
the "go" command. 


This Is a very powerful tool for debugging, which is not available with 
true (hardware) Z80 systems. You may in effect interrupt the Z80 at any 
point, actually pausing it between Z80 instructions. 


This also maintains compatabiIity with existing CP/M programs (like 
WORDSTAR) that want to read the X character. 


NOTE: When running PCDOS commands like type, dir, and so on 
from within the Emulator, the BREAK key may be unavailable to 
you. If you want to interrupt the output from such programs 
that are run "underneath" the Emulator, you may have to use 
the X key. 


Common PC DQS and CP/ M Fi le System 

The Emulator goes to great lengths to allow CP/M programs to read and 
write PCDOS files. Thus the PCDOS file system serves as a common 
environment for both PCDOS and CP/M files. This allows you to use your 
favorite IBM PC editor, for example, to edit source files that are then 
compiled within CP/M (using the Emulator) with ASM.COM, M80.COM, 

F80.COM, or whatever. 

CP/M’s "User Number" concept, however, is primitive compared to the 
directory structure available with PCDOS. So although the emulated BDOS 
supports the setting of a user number, the user number is ignored by the 
Emulator when it comes time to actually access files. 

Likewise, the concept of a Read-Only disk drive is not necessary under 
the Emulator. And the fatal CP/M flaw that crops up when you change 
disks and forget to type X to Warm Boot the system has been virtually 
eIiminated by PCDOS. 
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CP/M ond_i.ts. CCP (or lack of same) 

One thing that we did in order to achieve such a large TPA size (65022 
bytes) and such fast emulation was remove the console command part of 
CP/M (the Console Command Processor, or CCP) from the CP/M Segment. In 
fact, we did away with CP/M entirely. 
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The CCP is the part of a normal CP/M system which accepts commands from 
the user and processes them. The Digital Research CCP that comes with 
CP/M 2.2 is fairly limited in its power. 

In the Emulator, it is the main Z80MU 'C’-language program which 
contains all of the functions of CP/M’s CCP, and does a whole lot more. 
In fact, it is this program which emulates all of CP/M (with a lot of 
help from PCDOS). 

For this reason, there are certain CP/M enhancements (like ZCPR) which 
will have a whole lot of trouble working under the Emulator. The good 
news is that they are largely irrelevant under the Emulator, as the 
Emulator itself provides a powerful increase in console power even 
without ZCPR. 

So if you have dreams of running ZCPR (or any CP/M enhancement which 
counts on patching CP/M), you ought to forget about it. When using the 
Emulator, there’s no CP/M for such programs to patch. It’s all fakeware, 
invisible to Z80 programs. 

Stick with CP/M programs which interact with the outside world via the 
standard, unmodified BIOS and BOOS interfaces. 


CP/M 2.2 BIOS and BDQS Emulation 

The Emulator tries very hard to look to Z80 programs like CP/M version 
2.2, at least in terms of its BIOS calls and BOOS support functions. 

Most Z80 programs that are run under the Emulator will have no idea that 
they aren’t being run on a Z80 machine running Digital Research's CP/M. 

There are some hardware-specific aspects of CP/M, however, that make no 
sense on a PCDOS system. 

Many CP/M BIOS calls, for example, deal with the physical layout and 
operation of the floppy disk. Some of these are ignored. Others cause a 
fault of the Z80 program, with the display of a message to the effect 
that the program invoked an unsupported BIOS call. 

There are a few BDOS functions which likewise are irrelevant, and which 
cause the Z80 program to be aborted. 

The following is a list of the various BIOS calls that are supported by 
CP/M 2.2, and their effects under the Emulator. Calls that are marked 
"unsupported" cause the Z80 program to be aborted. 
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The addresses listed are absolute addresses within the CP/M Segment. 

Note that when the CP/M segment is Cold Booted, CP/M’s location zero is 
set to JMP BIOS+3 (FF03h - the Warm Boot vector). The only safe way for 
a Z80 program to locate this BIOS jump table in any CP/M system (not 
Just the Emulator) is to look at address 0001 within CP/M's memory. 

BIOS 

Address Function 

FF00h Cold Start CP/M segment 

FF03h Warm Start CP/M segment 

FF06h Set A-reg to FFh if Emulated VT52 Terminal has keypress 

[continued) 
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to be read, 00h if not 

FF09h Get keypress from Emulated VT52 Terminal to A-reg, via 
IBM's ROM BIOS 

FF0Ch Output C-reg to Emulated VT52 Terminal via IBM's ROM BIOS 

FF0Fh Output C-reg to LPT1: via IBM’s ROM BIOS 

FF12h Output C-reg to COM1: via IBM’s ROM BIOS 

FF15h Get char from C0M1: to A-reg via IBM’s ROM BIOS 

FF18h Home Disk (unsupported) 

FFIBh Select Disk (unsupported) 

FFlEh Set Track (unsupported) 

FF21h Set Sector (unsupported) 

FF24h Set DMA address (unsupported) 

FF27h Read Sector (unsupported) 

FF2Ah Write Sector (unsupported) 

FF2Dh Set A-reg to FFh if LPT1: ready for output, 00h If not, 
as reported by IBM’s ROM BIOS 
FF30h Sector Translate (unsupported) 


Similarly, here is a table of the various BDOS functions (in Decimal/- 
HEX), and their actions under the Emulator. Note that a CP/M BDOS 
function is invoked by loading the function number into C-reg, and 
doing a CALL 0005h. See standard CP/M documentation for detailed 
calling conventions . 


BDOS 

Function Action 


00/00h 

01/01h 

02/02h 

03/03h 

04/04h 

05/05h 


Warm Boot. Returns to accept more Emulator commands. Does 
not alter memory in the CP/M Segment. 

Read char from PCDOS standard input to A-reg. 

Send E-reg to PCDOS standard output. 

Read char from PCDOS AUX: device into A-reg. 

Send E-reg to PCDOS AUX: device 
Send E-reg to PCDOS PRN device 
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06/06h If E-reg on entry « FFh, then return in A-reg next char 
from PCDOS standard input, or 00h if none available 
at this Instant. 

If E-reg on entry <> FFh, then send E-reg to PCDOS 
standard output. 

07/07h Get IOBYTE to A-reg. 

08/08h Store E-reg into IOBYTE. 

09/09h Output string at (DE) to PCDOS standard output. 

10/0Ah Input line from PCDOS standard input to (DE). See Note 1 

be Iow. 

11/0Bh Set A-reg to FFh if char from PCDOS standard input is 
ready to be read, or 00h if not. 

12/0Ch Return CP/M version to HL. Sets reg L to 22h (for CP/M 
version 2.2), and reg H to 00h. 

13/0Dh Reset disk system. Sets DMA to 80h. Does not change 

selected drive to A: (like CP/M does), as this is 
not necessary with PCDOS. 

14/0Eh Set default drive to E-reg. 

15/0Fh Open file whose FCB is at (DE). Sets A-reg to 00h if 
successful, else to FFh. 

16/10h Close file whose FCB is at (DE). Sets A-reg to 00h if 
successful, else to FFh. 

17/11h Search for first file that matches pattern in FCB at 

(DE). Sets A-reg to 00h If successful, else to FFh. 
18/12h Search for next file that matches last pattern used. 

Sets A-reg to 00h If successful, else to FFh. 

19/13h Delete file(s) represented by FCB is at (DE). Sets A-reg 
to 00h if successful, else to FFh. 

20/14h Read next sequential record from file whose FCB is 
at (DE). Sets A-reg to status as follows: 

0 = successful 

1 * reading unwritten data (EOF) 

FFh » PCDOS returned error # 2: "No room in DTA for 
record" 
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Note that a short record is filled out by the Emulator 
with ^Z (eof) characters. 
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21/15h Write next sequential record to file whose FCB is at 

(DE). Returns status in A-reg as follows: 

0 * successful 

5 * diskette fulI 

6 * PCDOS returned error # 2: "No room in OTA for 

record" 

22/16h Create (and open) file whose FCB is at (DE). Sets A-reg 
to 00h if successful, else to FFh. 

23/17h Rename file(s) per special FCB at (DE). Sets A-reg to 
00h if successful, else to FFh. 

24/18h Return login vector (bitmap of known disks) to HL. Calls 
PCDOS to discover number of available drives. 

25/19h Return default drive number in A-reg. 

26/1Ah Set DMA to DE. 

27/1Bh Return allocation information (unsupported - aborts Z80 
program). See Note 2 below. 

28/1Ch Write-protect drive (ignored). 

29/1Dh Return write-protect vector (bitmap of $R/0 drives) to 
HL. Sets HL to zero (nobody’s write-protected). 
30/1Eh Set file attributes (ignored, but returns A-reg of 00h to 
indicate success). 

31/1Fh Return physical disk information (unsupported - aborts 
Z80 program). See Note 2 below. 

32/20h If E-reg on entry is FFh, then current user number is 
returned in A-reg. 

If E-reg on entry <> FFh, then current user number is set 
to E-reg MOD 32. 

This only updates the byte at CP/M address 4. The 

Emulator ignores this byte when accessing files. 

33/21h Read random record from file whose FCB is at (DE). 

Returns A-reg status as follows: 

0 ■ successful 
1 « reading unwritten data 

3 - (CP/M "Cannot close current extent" error): 

PCDOS returned error § 2: "No space in DTA for 
record" 

Note that a partial record is filled out by the Emulator 
with *Z (eof) characters. 
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34/22h Write random record to file whose FCB is at (DE). Returns 
A-reg status as follows: 

0 * successful 

3 ■ (CP/M "Cannot close current extent" error): 

PCDOS returned error # 2: "No space in DTA for 
record" 

5 ■ (CP/M "Directory Overflow" error): Diskette full 


35/23h Compute file size for file whose FCB is at (DE). Result 
goes Into random record field of FCB. 

36/24h Set random record field per FCB at (DE). 

37/25h Reset drive (accepted but ignored) 

38/26h (unsupported - aborts Z80 program) 

39/27h (unsupported - aborts Z80 program) 

( continued) 
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40/28h Write random record with zero fill. In the Emulator, this 
is translated to a function 34/22h (above). 

NOTE Is Function 10/0Ah is now done manually by the Z80 
engine, Instead of calling PCDOS. It now works much more like 
CP/M, except that ^R, ^E, are data characters instead of 
editing controls. 

NOTE 2: If someone will kindly provide us with a coherent 
writeup of the disk parameter block and allocation information 
as returned by BOOS functions 31/1Fh and 27/1Bh above, then 
we will gladly emulate these functions in the next release. 


In CP/M the BOOS routines call the BIOS routines. This is not true in 
the Emulator. The Emulator’s BDOS functions in general invoke the 
corresponding PCDOS functions, and the Emulator’s BIOS routines call the 
IBM PC ROM BIOS routines. The “terminal" builtin command (q.v.) controls 
what actually happens, at least as far as CP/M*s console character BDOS 
and BIOS requests are concerned. 
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BUILTIN COMMANDS 

This section describes those commands that are recognized and acted 
upon by the Emulator itself. Such commands do not involve a search of 
the disk for a corresponding .COM file, since the Emulator recognizes 
them as special commands which are to be handled within the Emulator 
itself. This process is roughly equivalent to the handling of CP/M’s CCP 
commands. 


Command Name Conflicts 

You may have a .COM (Z80 command) file that has the same name as one of 
these Builtin Commands. How do you tell the Emulator to run your .COM 
file, instead of doing its corresponding Builtin Command? All that you 
have to do Is convince the Emulator that your command is indeed a disk 
file. This can be done by including a drive ID or pathname as part of 
your command: 

Z80 A>a:dump foobar.asc 

Z80 A>b:\bin\dump foobar.asc 

Z80 A>\mystuff\dump foobar.asc 

Alternatively, you may want to rename your .COM file so that it no 
longer conflicts with an Emulator Builtin Command name. 


Numeric-Arqumenta 

Some Builtin Commands accept numeric arguments. These may represent 
addresses to be dumped, the number of pages to save, or whatever. 

A numeric argument may be entered in any of several ways: 

As a HEX number. No prefix is required in this case, as this is 
the default numeric radix. 
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Examples: ffff 0 7F -5 +3FF 
As a decimal number, prefixed by a period ("."). 

Examples: .10 .0 -.1 +.256 .65022 

As a binary number, prefixed with the percent sign ("%"). 
Examples: %0 %1010101011110000 -%1 
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As an ASCII character, prefixed by the apostrophe ("*"). 


Examples: ’A *" *0 -'Z 

As an ASCII escape sequence, prefixed by an apostrophe and back¬ 
slash 

Examp Ies: 


•w 

’\0 

*\b or '\B 
•\t or *\T 
*\n or *\N 
*\r or *\R 

# V 

•\" 

*\xFF or *\XFF 


(single "\" char) 

(NUL byte) 

S Backspace char) 

TAB char) 

(LINEFEED char) 

(CARRIAGE RETURN char) 

(single apostrophe ("'") char) 
(single double-quote char ) 
(byte with HEX value of FF) 


As a label which has been defined with the "label" builtin command. 


Examples: fcbl program_start BDOS -reserved 

As two or more of the above entries, connected with "+" or 
operators. 

Examples: 

fcbl+5 

program_end-tabIe_length 

*A-40+ * a 

tab Ie-5+of fset 
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The Builtin Commands are presented by functional grouping: 

- The PCDOS pass-through command prefix 

- CP/M Builtins that are emulated 

- Emulator Builtins that are similar to CP/M’s 

- General Emulator commands 

- Emulator DEBUG commands 

- CP/M Environment and file control commands 

- RESOURCE commands 
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3ui 1 tin.:. Ixxxxxx 

Passes command xxxxxx to PCDOS. This gives you a way to use the usual 
PCDOS utilities from within the emulator, without having them interpret¬ 
ed as CP/M commands. Everything after the "I" character is passed as a 
command to PCDOS. 

This command requires the reloading (by PCDOS) of the PCDOS COMMAND.COM 
file from disk. See the section on "The PCDOS Environment" for more 
detail on this subject. 

Since PCDOS handles the command (and any command arguments that may be 
present), the standard PCDOS "PATH" environment string may apply. So may 
all other PCDOS conventions, like I/O redirection, wildcards, PCDOS 
device names, etc. 

The given command is executed above the Emulator’s memory. This implies 
that there had better be enough memory available above the Emulator to 
run the given command. 


[continued) 
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You may use this facility to "drop into" PCDOS for a while (perhops to 
use a PCDOS screen editor on a CP/M source file), and then return to the 
Emulator. Use "Icommand" to drop into DOS, and "exit" to leave PCDOS and 
return to the Emulator. Make sure that COMMAND.COM is in your PCDOS PATH 
search list if you want to try this. 

This is also the primary way to take advantage of PCDOS’s directory 
structure while within CP/M. You may issue "CHOIR", "MKDIR", and other 
directory-related commands directly to PCDOS. The effect of such 
commands carries over to the Emulator. 
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Example (from an actual session): 

Z80 A>!cd \foo 
Z80 A>Icd \ 

Z80 A>!rd \foo 
Z80 A>!chkdsk b: 


362496 bytes 
1024 bytes 
272384 bytes 
89088 bytes 


total disk space 
in 1 directories 
in 10 user files 
available on disk 


423936 bytes total memory 
152384 bytes free 


Z80 A>!md foo 
Z80 A>!cd foo 
Z80 A>stat *.* 


Volume in drive A has no label 
Directory of A:\foo 

<DIR> n-19-85 1:15a 

<DIR> n-19-85 1:15a 

2 Flle(s) 144384 bytes free 

Z80 A>Icommand 


The IBM Personal Computer DOS 

Version 2.00 (C)Copyright IBM Corp 1981, 1982, 1983 

Tue 11-19-1985 1:16:00.18 
A:>chkdsk 


362496 bytes total disk space 
1024 bytes in 1 directories 
217088 bytes in 17 user files 
144384 bytes available on disk 

423936 bytes total memory 
149264 bytes free 
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Tue 11-19-1985 1:16:16.17 
A:>exit 

Z80 A>!format a: 
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3UILTIN COMMANDS: EMULATED CP/M BUILTIN’S 


Suiltin: d: 

Changes the default disk drive to the drive whose letter name is 
represented by the "d M character. The command prompt will change to 

Z80 d> 

to reflect the new default. Drive d’s current PCDOS directory will 
then be the first directory searched for Z80 command (.COM) files, 
unless explicitly overridden by a drive prefix or pathname. Data files 
that are created will default to that drive and its current directory. 
Data files that are read will be searched for only in that drive and 
directory, unless explicitly overridden by the Z80 program. 

Example (from an actual session): 

Z80 A>stat b:*.* 


Volume in drive B has no label 
Directory of B:\ 

WORDSTAR <DIR> 11-02-85 4:19a 

1 Flle(s) 89088 bytes free 

Z80 A>dir b:\wordstar\ws*.* 


Volume in drive B has no label 
Directory of B:\wordstar 


WSMSGS 

OVR 

27904 

11-06-85 

6:27p 

WS0VLY1 

OVR 

34048 

11-06-85 

6:30p 

WSU 

COM 

15872 

11-06-85 

6:32p 

WS 

COM 

15872 

11-06-85 

6:37p 


4 File(s) 89088 bytes free 


Z80 A>b: 
Z80 B>dir 


Volume in drive B has no label 
Directory of B:\ 

WORDSTAR <DIR> 11-02-85 4:19a 

1 File(s) 89088 bytes free 
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Z80 B>stat a:\*.exe 


Volume In drive A has no label 
Directory of A:\ 


Z80MU EXE 
1 F1 Ie(s) 


94976 11-18-85 3:31p 

142336 bytes free 
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BUILTIN COMMANDS: EMULATED CP/M BUILTIN’S 


Bui It In: del <pattern> 
era <pattern> 
delete <pattern> 
erase <pattern> 

These are Identical commands. All cause the Invocation of the PCDOS 
"DEL" command to delete files that match <pattern>. 

See the PCDOS manual for details of <pattern>. 

We have created several synonyms for the same command in order to make 
life easier for CP/M folks who are used to saying "ERA", and PCDOS 
folks who are used to saying "DEL" or whatever. 

These commands cause PCDOS to reload COMMAND.COM, so see "The PCDOS 
Environment" section for further detail on that subject. 

Examp Ie: 

Z80 A>erase b:*.asm 
Z80 A>del *.* 

Are you sure? y 
Z80 A>delete c:\backup\foo.* 

Z80 A>era foo.asm 
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Bui 11in: dir <pattern> 
stat <pattern> 

Shows a directory of files matching <pattern>. This invokes the PCDOS 
"DIR" command, so remember about COMMAND.COM (see "The PCDOS Environ¬ 
ment" section). 

<pattern> is passed directly to PCDOS. So see the PCDOS manual if you 
want to know what's legal. 

The CP/M STAT command (STAT.COM) cannot be emulated, because the 
first thing that Digital Research’s STAT.COM does is invoke a hardware- 
specific CP/M function that means nothing on the IBM PC, and is there¬ 
fore illegal within the Emulator. But the most common function of 
STAT.COM - displaying filenames and file sizes with "STAT *.*" or 
whatever - can be done with PCDOS's "DIR" command. So STAT and DIR have 
been made to do the same thing. If you’re used to typing "STAT *.*" in 
CP/M, then you'll be able to do the same thing under the Emulator. 

Example (from an actual session): 

Z80 A>stat b:*.* 


Volume in drive B has no label 
Directory of B:\ 

WORDSTAR <DIR> 11-02-85 4:19a 

1 File(s) 89088 bytes free 

Z80 A>dir b:\wordstar\ws*.* 


Volume in drive B has no label 
Directory of B:\wordstar 
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WSMSGS 

OVR 

27904 

11-06-85 

6:27p 

WS0VLY1 

OVR 

34048 

11-06-85 

6:30p 

WSU 

COM 

15872 

11-06-85 

6:32p 

WS 

COM 

15872 

11-06-85 

6:37p 


4 File(s) 89088 bytes free 


Z80 A>b: 
Z80 B>dir 
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Volume in drive B has no label 
Directory of B:\ 

WORDSTAR <DIR> 11-02-85 4:19a 

1 File(s) 89088 bytes free 

Z80 B>stat a:\a.exe 


Volume in drive A has no label 
Directory of A:\ 

Z80MU EXE 94976 11-18-85 3:31p 

1 FiIe(s) 142336 bytes free 
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Bui 11 in: type <fiIename.typ> 
ty <fiIename.typ> 

This command is the equivalent of the CP/M "TYPE" command. The specified 
file Is displayed on the standard output (normally the screen). 

The display may be paused with either the CP/M convention of A S/ A Q or 
the PCDOS convention of CTRL-NUMLOCK. It may be aborted with *C or 
CTRL-BREAK. 

This command causes PCDOS to reload COMMAND.COM, so see "The PCDOS 
Environment" section for further detail on that subject. 

Examp Ie: 

Z80 A>ty b:foo.asm 

Z80 A>type \source\backup\foo.doc 

Z80 A>ty ctest.err 
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Bu? 11 ? n: rename <oldpath> <newpath> 
ren <oldpath> <newpath> 

Renames the file specified by <oldpath> to the name given by <newpath>. 

NOTE: This is not the same syntax used by the CP/M equivalent, 
which is "REN <newname>*<oIdname>". 

This command causes PCDOS to reload COMMAND.COM, so see "The PCDOS 
Environment" section for further detail on that subject. 

This command invokes the PCDOS "RENAME" command. See the PCDOS manual 
for detaiIs. 
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Examp Ie: 


Z80 A>rename dbase.exe dbase.xxx 
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Bui I tin: save n <fIIename.typ> 
sa n <fI Iename.typ> 

Saves n 256-byte pages of CP/M memory (starting at address 0100h) to the 
specified file. The data written to the file is a simple memory image. 

No translation is done, even if a .HEX extension is given In the 
filename. If you want to write a true Intel HEX file, use the write 
Bui 11in. 

NOTE: This is close to the CP/M equivalent, except that the 
default radix for n is HEX, not decimal as with CP/M. 

Example (from an actual session): 

Z80 A>save 3 820init2.com 

Writing 3 pages (768 bytes) to file ’820INIT2.COM* 

Z80 A>save 0 continue.com 

Writing 0 pages (0 bytes) to file ’CONTINUE.COM’ 
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Bui 1 tin: copy <from_pattern> <to_path> 
co <from_pattern> <to_path> 

Copies the file(s) specified by <from_pattern> to the file or directory 
specified by <to_path>. 


This command invokes the PCDOS "COPY" command, so see the PCDOS manual 
for details as to what's legal. 


It also causes PCDOS to reload COMMAND.COM, so see "The PCDOS Environ¬ 
ment" section for further detail on that subject. 

This command is roughly equivalent to CP/M’s "PIP <outfiIe>*<infiIe>". 
You have the additional power of PCDOS’s directory and device name 
support, however. 

Examp Ie: 


Z80 A>copy *.* B: 

Z80 A>co b:*.asm 

Z80 A>copy \bin\*.* c:\backup 

Z80 A>copy *.asm combined.bak 

Z80 A>co *.asm *.bak 

Z80 A>co foo.asm Ipt1: 

Z80 A>co con autoexec.bat 
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Bui 11in: help [command] 

? [command] 

Displays a brief description of the requested Builtin Command. 

If no command name follows the "help" command, then a rather lengthy 
explanation of all commands is displayed. If you press the SPACE bar, 
this long listing will be interrupted at the next logical break. 
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The listing can be paused with ~S/~Q, or CTRL-NumLock. You can turn 
printer copying on before the listing starts (which is recommended) with 
or CTRL-PrtSc. 

Examp Ie: 

Z80 A>help xreg 
Z80 A>? list 
Z80 A>? 

Z80 A>heIp ? 

Z80 A>help b: 

Z80 A>heIp l 
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Built LiL-L illop [fault | nop] 
i [fault | nop] 

Specifies how the Emulator is to handle illegal Z80 opcodes. 

If "illop fault" is entered, then an illegal Z80 opcode will cause a Z80 
fault, meaning that the Emulator will stop executing the Z80 program and 
will display an error message to the effect that an illegal opcode was 
encountered at such-and-such and address. 

If "illop nop" is entered, then an illegal Z80 opcode will simply be 
ignored. This is closer to true Z80 operation. Execution will continue 
with the next Z80 instruction after the illegal opcode. 

If only "illop" is entered, then the Emulator simply reports how it is 
currently handling illegal opcodes. 

Example (from an actual session): 

Z80 A>i 

Illegal opcodes will act as NOP’s 
Z80 A>iI lop fault 

Illegal opcodes will FAULT 
Z80 A>illop nop 

Illegal opcodes will act as NOP's 
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Bui I lilU exit 


Exits the Emulator, and returns to PCDOS. 

Due to certain limitations within PCDOS, you should not remove any 
floppy disks that are being used until you have exited the Emulator via 
this command, unless you know that the Z80 programs which you have run 
have truly closed any files that have been written to. 

We have used the Emulator extensively, and have frequently changed 
floppies while within the Emulator. We have never experienced corrupted 
floppy data. But then, we use only "safe" CP/M software like ASM.COM, 
M80.COM, L80.COM, and so on. Such programs are very good about closing 
files when they exit. 

This warning is included not because it has ever happened to us, but 
because we wrote the code, and we know about certain "windows" within 
which a faulting CP/M program could conceivably confuse PCDOS into 
writing one floppy’s data to another floppy, destroying the second 
floppy’s file data and perhaps even its FAT (File Allocation Table). 
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Examp Ie: 

Z80 A>exIt 
A> 
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Bui I tin: speed? 

howfast? 

Calculates the effective speed of the imaginary Z80 that exists within 
the Emulator. 

In response to this command, a sample Z80 program is loaded into the 
CP/M segment. It is run, and its execution is timed. This program takes 
up to half a minute to run on a simple IBM PC with an 8088, and corres¬ 
pondingly less time on faster machines (i.e. - a PC with a NEC V20 chio 
an IBM PC/AT, etc). 

The effective clock speed is displayed at the end of the test. 

The reported speed should be taken with a grain of salt. What it means 
Is that if you had a real Z80 running the exact instruction mix found in 
the test program, then that real Z80 would have to run at the reported 
clock speed in order to perform as fast (or slow) as the Emulator’s 
imaginary Z80. 

For example, assume that the reported effective clock is 250,000 Hz. 

This means that the imaginary Z80 in the Emulator is running the test 
program at one fourth the speed of a 1 MegaHertz Z80 (as found on a 
Microsoft SoftCard in an Apple, for example), one eighth the speed of a 
2 MegaHertz Z80, etc. 

Does this mean that your CP/M programs run under the Emulotor will run 
at one fourth the speed of an Apple with a SoftCard? Not necessarily 
The reported speed is for CPU-bound (no I/O) operation, of the exact mix 
of instructions found in the test program. Real CP/M programs tend to 
have a mix of CPU and I/O operations. I/O operations to disk are handled 
as fast as the IBM PC can do them. They aren’t emulated, they are done. 
And CP/M programs whose CPU-bound operations involve a lot of register- 
to-register operations will be emulated faster than those requiring a 
lot of memory accesses. 

It’s a complicated relationship. Our experience has been that ASM.COM, 
for example, runs about 1/5th the speed under the Emulator on a stock, 
floppy-based IBM PC than it does on an Apple with a SoftCard and 1 
MegaHertz Z80. Target PlannerCalc (a spreadsheet program) runs about 
1/2 speed. The addition of a NEC V20 processor to the IBM PC improves 
the speed of the Emulator. So does using a hard disk instead of flop¬ 
pies. And moving the Emulator to a Compaq DeskPro 286 brings emulated 
performance close to that of a 1 MegaHertz Z80. 
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NOTE: This command causes a Cold Boot of the CP/M segment. 
This destroys any CP/M program that you may have had in 
memory. 

Example (from an actual session): 

Z80 A>speed? 

*** CP/M Segment C0LDB00TED *** 

Beginning Z80 timing test. Please wait... 

Effective Z80 clock speed is 248101 Hz 
*** CP/M Segment C0LDB00TED *** 
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BUILTIN COMMANDS: DEBUG SUPPORT 


SuiItin: btrace [ SOME | ALL ] 
bt [ SOME | ALL ] 

Displays the current BDOS Trace Table (if no arguments are present), or 
controls the BDOS functions that will be traced. 

As a CP/M program is run, the various BDOS calls that it makes are 
traced. This command displays the trace table as it has been left by the 
last CP/M program run. 

Items reported include: 

1) The logical sequence number. 

2) The Program Counter of the CALL to the BDOS. 

3) The contents of the Z80 DE register at the entry to the BDOS 

hand Ier. 

4) The DMA address in effect at the instant of this BDOS call. 

5) The BDOS function # (as passed in the Z80 C-reg) and a text 

description of the function being performed. 

The BDOS Trace Table is cleared by a COLD BOOT, by the load of a new 
CP/M program, and at various other times when it seems logical to clear 
it out. 

If an argument (either "SOME" or "ALL") is present, then the trace 
table is not displayed. Instead, the Emulator adjusts (according to the 
argument) the way that future traces will be made: 

If "SOME" is specified, then the Console Status, Console 
Output, Direct Console I/O, and List Output BDOS functions 
will not be traced. This can help to keep the BDOS Trace Table 
from filling up with unimportant entries. 

If "ALL" is specified, then even these console character BDOS 
functions will be traced. 
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Example (from an actual run of DUMP.COM): 

Z80 A>btrace a I I 

Future BDOS traces will include console character functions 
Z80 A>a:dump dump.com 

0000 21 00 00 39 22 15 02 31 57 02 CD Cl 01 FE FF C2 

0010 IB 01 11 F3 01 CD 9C 01 C3 51 01 3E 80 32 13 02 

0020 21 00 00 E5 CD A2 01 El DA 51 01 47 7D E6 0F C2 

... (Much of DUMP.COM output deleted for brevity) 

0150 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 0® 

0160 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 

0170 00 00 00 00 00 00 00 00 00 00 00 00 00 00 0® 00 

Z80 A>bt 

BDOS TRACE TABLE: 

SEQ# Z80PC Z80DE Z80DMA FUNCTION 


006 016BH 0030H 0080H 02H Console Output from E-reg « 0 
007 016BH 0030H 0080H 02H Console Output from E-reg - 0 
008 016BH 0020H 0080H 02H Console Output from E-reg ■ 


(Many entries deleted for brevity) 
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049 016BH 
050 01D6H 
051 016BH 
052 016BH 

244 016BH 

245 016BH 

246 016BH 

247 016BH 

248 016BH 

249 016BH 

250 016BH 

251 016BH 

252 015EH 

253 016BH 

254 016BH 

255 016BH 
001 016BH 


0030H 
005CH 
000DH 
000AH 
0020H 
0030H 
0030H 
0020H 
0030H 
0030H 
000DH 
000AH 
0070H 
0030H 
0031H 
0037H 
0030H 


0080H 02H Console Output from E-reg « 0 
0080H 14H Read File (Sequential), FCB at (DE) 
0080H 02H Console Output from E-reg ■ ~M 

0080H 02H Console Output from E-reg ■ 

0080H 02H Console Output from E-reg ■ 

0080H 02H Console Output from E-reg - 0 

0080H 02H Console Output from E-reg ■ 0 

0080H 02H Console Output from E-reg ■ 

0080H 02H Console Output from E-reg ■ 0 

0080H 02H Console Output from E-reg ■ 0 

0080H 02H Console Output from E-reg - 

0080H 02H Console Output from E-reg * 

0080H 0BH Get Console Status to A-reg 
0080H 02H Console Output from E-reg - 0 

0080H 02H Console Output from E-reg ■ 1 

0080H 02H Console Output from E-reg ■ 7 

0080H 02H Console Output from E-reg « 0 
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002 016BH 0020H 0080H 02H Console Output 

003 016BH 0030H 0080H 02H Console Output 

004 016BH 0030H 0080H 02H Console Output 

005 016BH 0020H 0080H 02H Console Output 

-- END OF BDOS TRACE TABLE — 


from E-reg = 
from E-reg ■ 0 
from E-reg ■ 0 
from E-reg ■ 
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Bu i 11in: break 

break cI ear Tn [n... ] ] 
break set n [n... ] 
b 

b clear [n [n...]] 
b set n [n...] 

Manipulates the Breakpoint Table, which contains up to 50 Z80 addresses 
at which execution of the Z80 is to be halted, and control returned to 
the Emulator's command prompt. 

Breakpoints are typically used in conjunction with the "read" and "go" 
commands, and various other debug commands. 

breakpoint T at>le is cleared when a new CP/M program is loaded, when 
the CP/M Segment is Cold Booted, and at various other times when it 
seems logical to clear It. 

If only "break" is entered, then the current Breakpoint Table addresses 
are displayed. 

If "break set" is entered followed by one or more Z80 addresses, then 
the addresses following the command are added to the Table. 

If only "break clear" Is entered, then all active breakpoint addresses 
are removed. No execution breakpoints will occur. 

""break c * ear " entered followed by one or more Z80 addresses, then 
only the specified addresses are removed from the Breakpoint Table. 

NOTE: When a breakpoint is encountered during execution of the 
Z80 code, that breakpoint’s address is automatically cleared 
from the table. 
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BUILTIN COMMANDS: DEBUG SUPPORT 


Examp Ie: 

Z80 A>break clear 

0 Breakpoints cleared 
Z80 A>b set startup startup+3 14f 210 221 
5 Breakpoints set - 5 now in table 
Z80 A>b clear 221 

1 Breakpoints cleared, 4 left 
Z80 A>b 

Current Breakpoints: 

0100H 0103H 014FH 0210H 

4 Breakpoints currently set 

Z80 A>b clear 210 startup 

2 Breakpoints cleared, 2 left 
Z80 A>b 

Current Breakpoints: 

0103H 014FH 

2 Breakpoints currently set 
Z80 A>b clear 

2 Breakpoints cleared 
Z80 A>b 

Current Breakpoints: 

0 Breakpoints currently set 
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Bu i11in: dump [n1 [n2]] 
d [nl [n2J] 

Dumps Z80 (CP/M) memory in HEX and ASCII. 

If nl is given, then the first address dumped is nl. If no arguments are 
present, then the first address is the one following the last one 
done by a previous dump command. 

If n2 is given, then the dump continues through Z80 (CP/M) address n2. 

If n2 is not given, then n2 is assumed to be 255 bytes beyond the 
starting address. 

A lengthy dump may be interrupted by pressing the SPACE bar. 

Example (from an actual session): 


Z80 A>dump 100 


ADDR 

00 

01 

02 

03 

04 

05 

06 

07 

08 

09 

0A 

0B 

0C 

0D 

0E 

0F 

01234567 

89ABCDEF 

0100: 

21 

00 

00 

39 

22 

15 

02 

31 

57 

02 

CD 

Cl 

01 

FE 

FF 

C2 

!..9"..1 

W.MA.~.B 

0110: 

IB 

01 

11 

F3 

01 

CD 

9C 

01 

C3 

51 

01 

3E 

80 

32 

13 

02 

...s.M.. 

CQ.>.2.. 

0120: 

21 

00 

00 

E5 

CD 

A2 

01 

El 

DA 

51 

01 

47 

7D 

E6 

0F 

C2 

1..eM".a 

ZQ.Gjf.B 

0130: 

44 

01 

CD 

72 

01 

CD 

59 

01 

0F 

DA 

51 

01 

7C 

CD 

8F 

01 

D.Mr.MY. 

.ZQ.1M.. 

0140: 

7D 

CD 

8F 

01 

23 

3E 

20 

CD 

65 

01 

78 

CD 

8F 

01 

C3 

23 

|M..#> M 

e.xM..C# 

0150: 

01 

CD 

72 

01 

2A 

15 

02 

F9 

C9 

E5 

D5 

C5 

0E 

0B 

CD 

05 

.Mr.*..y 

IeUE..M. 
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0160: 

00 

Cl 

D1 

El 

C9 

E5 

D5 

C5 

0E 

02 

5F 

CD 

05 

00 

Cl 

D1 

.AQaleUE 

.._M..AQ 

0170: 

El 

C9 

3E 

0D 

CD 

65 

01 

3E 

0A 

CD 

65 

01 

C9 

E6 

0F 

FE 

aI>.Me.> 

.Me.If.~ 

0180: 

0A 

D2 

89 

01 

C6 

30 

C3 

8B 

01 

C6 

37 

CD 

65 

01 

C9 

F5 

.R..F0C. 

.F7Me.Iu 

0190: 

0F 

0F 

0F 

0F 

CD 

7D 

01 

FI 

CD 

7D 

01 

C9 

0E 

09 

CD 

05 

. .. .M|.q 

M( . I..M. 

01A0: 

00 

C9 

3A 

13 

02 

FE 

80 

C2 

B3 

01 

CD 

CE 

01 

B7 

CA 

B3 

.1:..~.B 

3.MN.7J3 

01B0: 

01 

37 

C9 

5F 

16 

00 

3C 

32 

13 

02 

21 

80 

00 

19 

7E 

B7 

.7I_..<2 

..!...~7 

01C0: 

C9 

AF 

32 

7C 

00 

11 

5C 

00 

0E 

0F 

CD 

05 

00 

C9 

E5 

D5 

1/21. A. 

..M..IeU 

01D0: 

C5 

11 

5C 

00 

0E 

14 

CD 

05 

00 

Cl 

D1 

El 

C9 

46 

49 

4C 

EA...M. 

.AQalFIL 

01E0: 

45 

20 

44 

55 

4D 

50 

20 

56 

45 

52 

53 

49 

4F 

4E 

20 

31 

E DUMP V 

ERSION 1 

01F0: 

2E 

34 

24 

0D 

0A 

4E 

4F 

20 

49 

4E 

50 

55 

54 

20 

46 

49 

.4$..NO 

INPUT FI 


Z80 

A>d primary_fcb secondary_fcb+. 

,15 







ADDR 

00 

01 

02 

03 

04 

05 

06 

07 

08 

09 

0A 

0B 

0C 

0D 

0E 

0F 

01234567 

89ABCDEF 

0050: 













01 

44 

55 

4D 


.DUM 

0060: 

50 

20 

20 

20 

20 

43 

4F 

4D 

00 

00 

80 

00 

80 

01 

00 

00 

P COM 


0070: 

6D 

0B 

IB 

BF 

40 

F3 

00 

00 

00 

F3 

00 

00 





m..?@s.. 

. 8 . . 
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Bui I tin: go [n] 
9 [n] 


Begins execution of Z80 code at address n. If n is not specified, then 
the starting address defaults to the current Z80 Program Counter (PC). 

This is the usual way to run a program that has been read from disk. It 
is also used to continue execution when the Z80 has been stopped via o 
breakpoint, or by the user pressing the BREAK key. 

NOTE: A Z80 command (.COM) file that is invoked by typing 
Its nome Is automatically run. It does not require this 
command In order to be executed. 

Examp Ie: 

Z80 A>go 
Z80 A>g 100 
Z80 A>g -.768 
Z80 A>go fix!t5-3 
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Built in: find n "text" 
f n "text" 


Searches the CP/M Segment 
"text". The search begins 
described at the start of 


for the binary pattern represented by string 
at Z80 address n, which is a numeric value as 
this section. 


The "text" string may (and usually does) include imbedded escape 
sequences, as follows: 


\\ 

\0 

\b or \B 
\t or \T 
\n or \N 
\r or \R 
V 
V* 

\xFF or \XFF 


(single "\" char) 

(NUL byte) 

(Backspace char) 

(TAB char) 

(LINEFEED char) 

(CARRIAGE RETURN char) 

(single apostrophe ("’") char) 
(single double-quote char ) 
(byte with HEX value of FF) 


The CP/M Segment address of each match is displayed as a four-digit HEX 
value. The search ends with CP/M Segment address 0FFFFh. 
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Example (from an actual session): 

Z80 A>patch 8000 M Joan Riff" 

Z80 A>f!nd 100 "Joan" 

8000H 

Z80 A>f .256 M \xcd\x05\x00" 

015EH 016BH 019EH 01CAH 01D6H 
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9uiI tin: patch [n] 

patch n "xxxx" 

P [n] 

p n ''xxxx 1 ' 

Either enters an interactive patch dialog which allows you to change 
CP/M memory a byte at a time, or else applies string patch "xxxx' to the 
CP/M Segment and does not enter interactive patch mode. 

If n (which is a numeric value as defined at the start of this section) 
is specified, then patching starts at address n. If n is not specified, 
then patching begins with next patch location (the one above the last 
location patched). Note that in the patch n "xxxx” format, numeric 
value n is required. 

The interactive patch dialog consists of: 

1) a prompt which shows the next address to be patched and Its 
current contents. 


2) user responses. 

User responses to the interactive patch prompt are as follows: 

?<return> A question mark (followed by RETURN) to request a short 
help message showing available responses. 

n<return> A standard numeric argument as described at the start 

of this section. This is the byte value to be patched into the 
specified CP/M address. 

NOTE: This may also be a 16-bit value. If the high-order 
byte of the resultant n is non-zero, then this is taken 
to be a 16-blt value, and fills 2 bytes. 


"xxx" A string of ASCII text, delimited by double-quote characters. 
The bytes of the string are patched into successive CP/M 
memory locations. The string may include ASCII escape se¬ 
quences as foilows: 


\\ 

\0 

\b or \B 
\t or \T 
\n or \N 
\r or \R 
V 


(single M \" char) 

(NUL byte) 

(Backspace char) 

(TAB char) 

(LINEFEED char) 

(CARRIAGE RETURN char) 

(single apostrophe (.) char) 
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\« (single double-quote char ) 

\xFF or \XFF (byte with HEX value of FF) 


<spacexreturn> to leave the addressed byte unchanged, and move to 
next one. 

<return> to exit the interactive patch mode. 

[continued) 


BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 133 







October 


;xxx A comment (everything following the semicolon is Ignored). 


Examp Ie (from an actual session): 
Z80 A>patch 400 


Enter *?' for help with PATCH entries 


0400H (00H) - *R 
0401H (00H) - *1+20 
0402H (00H) « “ff\0» 
0405H (00H) - 


280 

ADOR 00 

0400: 52 

Z80 

Z80 

ADDR 00 

0050: 
0060: 52 
0070: 60 


A>d 400 40f 

tl 08 tl 06 87 08 09 0A 08 0C 00 0E 0r 01254567 89ABCDEF 

69 66 66 00 00 00 00 00 00 00 00 00 00 gg 00 Riff . 

A>p prlmary_fcb "JoonRiff 


A>d prlmory_fcb secondary_fcb+.15 


-1 0A f 8 06 07 08 09 0A 08 0C 00 0E 0F 01234567 89ABCDEF 


69 66 66 20 20 20 40 
0B IB BF 40 F3 00 00 


4A 6F 61 

00 00 80 00 80 01 00 
00 F3 00 00 


6E Joon 

00 Riff M . 

w..?@s.. . s . . 


"Z80MU" Z80 and CP/M 2.2 Emulator 
BUILTIN COMMANDS: DEBUG SUPPORT 


User *s Guide 


Page 60 


B.Ui 11 in : xreg [rr n] 
x [rr n] 


Sets Z80 register or flag rr to value n. 


If no args are present, 
are displayed. 


then the current Z80 register values and flags 


If args are present, then the 
to the numeric value n (whose 
this section). 


register or flag represented by rr is set 
format is described at the beginning of 


onH E riI!! e Z ?u ha ?.° pr ! mor y and on alternate set of registers 
and flags. The alternate set is indicated by appendina an 
apostrophe (.) to the register or flag name 9 


faMAwliwt 0r tIk Q9 t0 be s#t ( the rr ar 9 umen t) must b< 
following (in either upper or lowercase): 


one of the 


regs: A F 

A* F * 

AF BC 
AF * BC * 
IX IY 
IFF1 IFF2 

flags: SF ZF 

SF' ZF * 


B 

C 

D 

E 

B* 

C' 

D* 

E ’ 

DE 

HL 



DE’ 

HL * 



SP 

PC 



IMF 

I 

R 


HF 

P/V 

NF 

CF 

HF’ 

P/V* 

NF * 

CF 


Example (from an actual session): 


H 
H * 


L 

L* 


Z80 A>xreg pc 0 


Z80 A>x 
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AFBCDEHLIX IY I R SP PC IFF1 IFF2 IMF 
0A01 000F 007F FEFC 0000 0000 00 00 FEFE 0000 000 

0000'0000’0000’0000'SF=0 ZF-0 HF=0 P/V=0 NF»0 CF=1 
L0000: C3 03 FF JP LFF03 

Z80 A>xreg be ffff 
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Z80 A>x 

A F B C D E H L IX IY I R SP PC IFF1 IFF2 IMF 

0A01 FFFF 007F FEFC 0000 0000 00 00 FEFE 0000 000 

0000’0000’0000’0000’SF«0 ZF«0 HF-0 P/V-0 NF-0 CF-1 
L0000: C3 03 FF JP LFF03 

Z80 A>x c’ ’A 

Z80 A>xreg de .256 

Z80 A>xreg AF’ 55 

Z80 A>xreg 

A F B C D E H L IX IY I R SP PC IFF1 IFF2 IMF 

0A01 FFFF 0100 FEFC 0000 0000 00 00 FEFE 0000 000 

0055’0041’0000’0000’SF-0 ZF-0 HF=0 P/V=0 NF-0 CF=1 
L0000: C3 03 FF JP LFF03 
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BuiItin: trace [n] 
t [n] 

Traces a certain number (specified by the n argument)of Z80 instruction 
executions, displaying Z80 regs and flags after each instruction’s 
execution. 

Execution begins at the current Z80 Program Counter (PC). 

If no argument is given, then n defaults to 1. 

The n argument is a numeric value as described at the beginning of this 
section. 

NOTE: The PC of each executed instruction is saved in a 
circular buffer for later interpretation by the '•pc?'* builtin 
command(q.v.). 

Example (from an actual trace of DDT.COM’s opening lines): 

Z80 A>read ddt.com 

*** Low - 0100H Next - 1400H 

*** Z80 DMA, PC and Stack automatically set for .COM file 
280 A>t 4 

A F B C D E H L IX IY I R SP PC IFF1 IFF2 IMF 

0A01 0FBC 0100 FEFC 0000 0000 00 00 FEFC 0103 0 0 0 

0055*0041*0000’0000’SF-0 ZF-0 HF-0 P/V-0 NF-0 CF-1 
L0103: C3 3D 01 JP L013D 

A F B C D E H L IX IY I R SP PC IFF1 IFF2 IMF 

0A01 0FBC 0100 FEFC 0000 0000 00 00 FEFC 013D 000 

0055*0041’0000’0000’SF-0 ZF-0 HF-0 P/V-0 NF-0 CF-1 
L013D: 31 00 02 LD SP,L0200 


(continued) 
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A F B C 

D E H L IX 

IY 

I R SP 

PC 

IFF 1 

IFF2 

IMF 

0A01 0FBC 

0100 FEFC 0000 

0000 

00 00 0200 

0140 

0 

0 

0 

0055'0041 

'0000'0000'SF-0 

ZF-0 

HF-0 P/V-0 

NF-0 

CF-1 



L0140: 

C5 

PUSH 

BC 





A F B C 

D E H L IX 

IY 

I R SP 

PC 

IFF 1 

IFF2 

IMF 

0A01 0FBC 

0100 FEFC 0000 

0000 

00 00 01FE 

0141 

0 

0 

0 

0055'0041 

*0000'0000'SF-0 

ZF-0 

HF-0 P/V-0 

NF-0 

CF-1 


L0141: 

C5 

PUSH 

BC 
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Bui I tin: notrace [n] 
n [n] 

Executes a certain number (specified by the n argument) of Z80 instruc¬ 
tions, beginning at the current Z80 Program Counter (PC). The Z80 
registers are not displayed after every instruction, but are displayed 
after the last instruction. 

f 

If no argument is given, then n defaults to 1. 

The n argument is a numeric value as described at the beginning of this 
sect ion. 

NOTE: The PC of each executed instruction is saved in a 
circular buffer for later interpretation by the "pc?" builtin 
command(q.v.). 

Examp Ie: 

Z80 A>n 3 

A F B C D E H L IX IY I R SP PC IFF1 IFF2 IMF 
0A01 0F09 0130 FEFC 0000 0000 00 00 01FA FEFE 000 
0055*0041 '0000'0000’SF-0 ZF-0 HF-0 P/V-0 NF-0 CF-1 
LFEFE: 76 HALT 
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Built in; pctrace? [FIRST/LAST n [FULL/BRIEF] ] 
pc? [FIRST/LAST n [FULL/BRIEF] ] 


Displays the Z80 PC’s which were saved during the last "trace" or 
"notrace" execution. This is very useful for finding out how the Z80 
wound up at a particular address, or where it went from there. 


The display may proceed from the oldest PC toward the newest (FIRST n), 
or in the reverse direction (LAST n). 


The display may include only the PC itself (BRIEF) or the complete 
disassembled instruction at each PC (FULL). 


Note that a FULL display assumes that instructions haven't been 
since they executed. All that is saved in the circular PC queue 
PC itself. For a FULL display, the current contents of whatever 
that address is disassembled. 

The n argument is a numeric value as described at the beainnina 
section. 


modified 
i s the 
i s at 


of this 


The default is LAST .512 FULL. 
Examp Ie: 

Z80 A>pc? 

Z80 A>pctrace? first .20 full 
Z80 A>pc? last .20 brief 
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Rui 11 in: move nlow nhigh ndest 
m nlow nhigh ndest 

Moves CP/M memory from one location within the CP/M Segment to another 
location within the CP/M Segment. 

The block of memory to be moved is defined by nlow through nhigh. 

The new location for the block is defined by ndest. 

All three arguments are numeric values as described at the start of this 
section. 

NOTE: The move is done either Ieft-to-right or right-to-left, 
as needed. So no smearing is possible. 

Example (from an actual session): 

Z80 A>p primary_fcb "JoanRiff 

Z80 A>d primary_fcb secondary_fcb+.15 

ADDR 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 00 0E 0F 01234567 89ABCDEF 

0050 . 4A 6 F 61 6 E Joan 

0060: 52 69 66 66 20 20 20 40 00 00 80 00 80 01 00 00 Riff M . 

0070: 60 0B IB BF 40 F3 00 00 00 F3 00 00 m..?@s.. .s.. 

Z80 A>move primary_fcb secondary_fcb secondary.fcb 

Z80 A>d primary_fcb secondary_fcb+.15 

ADDR 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 00 0E 0F 01234567 89ABCDEF 

0050 . 4A 6 F 61 6 E Joan 

0060: 52 69 66 66 20 20 20 4D 00 00 80 00 4A 6 F 61 6 E Riff M ....Joan 

0070: 52 69 66 66 20 20 20 40 00 00 80 00 Riff M .... 
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Bu i 11 in: math <expression> 
ma <expression> 

Prints 16-bit evaluated result of expression, which is composed of 
numeric values (as described at the start of this section) connected 
with •+• or •-* operators. 

The evaluated result is printed in HEX and decimal, as both positive 
and negative numbers. 

Example (from an actual session): 

Z80 A>math 0-7ff 

HEX: F801H -07FFH Dec: 63489 -02047 

Z80 A>ma secondary_fcb-primary_fcb 

HEX: 0010H -FFF0H Dec: 00016 -65520 

Z80 A>mo 'A-40+'a 

HEX: 0062H -FF9EH Dec: 00098 -65438 


(continued) 
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Bui I tin: args <tail> 
ar <tail> 

Formats default FCB’s at 5Ch and 6Ch as well as default DMA at 80h per 
command tall, exactly as if <taiI> had followed a Z80 command (.COM) 
fI Iename. 

This command is most useful for "filling in" a command tall for Z80 code 
that has been "read" into CP/M memory and which will look for command- 
I Ine arguments. 

For instance, you may want to debug Digital Research’s DDT.COM program, 
while telling DDT to load file FOO.COM. You would first load DDT via 

read 100 ddt.com 

You would then fill in DDT’s command-line arguments with 
args foo.com 

When executed, DDT would then see "FOO.COM" in both the first FCB at 5Ch 
and as a raw command tail at 80h. 

Example (from an actual session): 

Z80 A>args testfile001 file0002 


Z80 A>d pr!mary_fcb secondary..fcb+.15 


ADDR 00 

01 02 03 04 

05 

06 

07 

08 

09 

0A 

0B 

0C 

0D 

0E 

0F 

01234567 

89ABCDEF 

0050: 









00 

54 

45 

53 


.TES 

0060: 54 

46 49 4C 45 

30 

30 

31 

00 

00 

00 

00 

00 

46 

49 

4C 

TFILE001 

.FIL 

0070: 45 

30 30 30 32 

20 

20 

20 

00 

00 

00 

00 





E0002 


Z80 

A>d 80 9f 














ADDR 00 

01 02 03 04 

05 

06 

07 

08 

09 

0A 

0B 

0C 

0D 

0E 

0F 

01234567 

89ABCDEF 

0080: 15 

20 54 45 53 

54 

46 

49 

4C 

45 

30 

30 

31 

20 

46 

49 

. TESTFI 

LE001 FI 

0090: 4C 

45 30 30 30 

32 

0D 

00 

00 

00 

00 

00 

00 

00 

00 

00 

LE0002.. 


Z80 

A>args foo.< 

c -n -1 

5 -V 
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Z80 

A>d primary. 

.f cb 

► secondary 

'_f cb+. 

15 







ADDR 00 

01 02 03 04 

05 

06 

07 

08 

09 

0A 

0B 

0C 

0D 

0E 

0F 

01234567 

89ABCDEF 

0050: 









00 

46 

4F 

4F 


.FOO 

0060: 20 

20 20 20 20 

43 

20 

20 

00 

00 

00 

00 

00 

2D 

4E 

20 

C 

.-N 

0070: 20 

20 20 20 20 

20 

20 

20 

00 

00 

00 

00 







Z80 

A>d 80 9f 














ADDR 00 

01 02 03 04 

05 

06 

07 

08 

09 

0A 

0B 

0C 

0D 

0E 

0F 

01234567 

89ABCDEF 

0080: 0F 

20 46 4F 4F 

2E 

43 

20 

2D 

4E 

20 

2D 

42 

20 

2D 

56 

. FOO.C 

-N -B -V 

0090: 0D 

45 30 30 30 

32 

0D 

00 

00 

00 

00 

00 

00 

00 

00 

00 

.E0002.. 
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BuiLti n: coldboot! 
cold! 

Cold Boots CP/M memory by zeroing the 64K CP/M Segment, installing the 
BIOS and BOOS hooks, formatting the first page of memory just as CP/M 
would, etc. 

When you first start up the Emulator, the CP/M Segment has already been 
Cold Booted. 

You may use this command to clean things up when you suspect that Z80 
software may have corrupted the BIOS or BDOS hooks, garbaged page zero, 
or whatever. 

If a Z80 program exits with an Emulator message to the effect that the 
program requests termination via Cold Boot, then you should use this 
command to do it. The Z80 program probably had a good reason for asking 
for a Cold Boot. 

Examp Ie: 

Z80 A>coIdboot! 

*** CP/M Segment COLDBOOTED *** 

"Z80MU" Z80 and CP/M 2.2 Emulator User’s Guide Page 70 

BUILTIN COMMANDS: CP/M ENVIRONMENT CONTROL 


Builtin: terminal [ BIOS | NONE | BOTH | BDOS ] 

term [ BIOS | NONE | BOTH | BDOS ] 

Controls the builtin VT52 "emulated terminal" (described previously), 
whose I/O goes stroight to the IBM PC screen via the IBM PC ROM BIOS 
routines and is therefore never seen by PCDOS. 

If BIOS is specified, then CP/M BIOS colls that deal with console input 
or output will be routed to the builtin VT52 terminal emulator. Cor¬ 
responding CP/M BDOS functions will go to PCDOS for handling. 

If NONE is specified, then neither CP/M BIOS calls nor CP/M BDOS 
functions will be routed to the builtin VT52 terminal emulator. All 
will go to PCDOS for handling. 

If BOTH is specified, then console character CP/M BIOS colls and 
corresponding CP/M BDOS functions will be routed to the builtin VT52 
terminal emulator. None will go to PCDOS for handling. 

If BDOS is specified, then CP/M BDOS colls that deal with console input 
or output will be routed to the builtin VT52 terminal emulator. Cor¬ 
responding CP/M BIOS functions will go to PCDOS for handling. 

NOTE: This command allows additional flexibility in configu¬ 
ring your CP/M progroms to run under the Emulator. Some 
packages do console I/O via BIOS, others vio BDOS. Now you 
can route either one to the builtin VT52 terminal emulator. 


Example: 

Z80 A>term BOTH 
Z80 A>terminol none 


(continual) 
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Bui 11in: read [n] <fiIename.typ> 
r [n] <fI Iename.typ> 

Reads data from specified file Into the CP/M Segment, ot address n. 

If n is absent, then It defaults to 0100. 

This is the primary method used to load Z80 software for debugging It 
is norma I 1y used to read Z80 command (.COM) files into memory, but this 
command will also read raw data files with no problem. 

If <f11ename.typ> has a filetype of .HEX, then the file is assumed to be 
in standard Intel HEX format, and is loaded into memory at addresses 
specified by the HEX records. In such a cose, the n argument may have no 
meaning. 7 

The n argument is a numeric value of the sort described at the beginnina 
of this section. 3 * 


NOTE: If a read of a file causes data to be read below 0100h 
or above FD00h, then the CP/M environment will be clobbered 
If you’re developing non-CP/M Z80 code, then who cares? If 
you’re reading in a file that expects to call CP/M, however 
then running the thing with a clobbered CP/M environment just 
might scramble the brains of the imaginary Z80. 

This command is used by us at CCS to load test versions of our Z80 
software, which we leave in .HEX format when we run L80. 

Examp Ie: 

Z80 A>read 100 820init.com 


*** Low « 0100H Next » 0380H 

*** Z80 DMA, PC and Stack automatically set for .COM file 
Z80 A>wrlte 100 360 820init.hex 

Writing HEX records for 0100H thru 0360H (609 bytes} to file 
'820INIT.HEX’ 7 J 

Z80 A>read 820init.hex 


*** .HEX file Starting Address = 0100H 
*** Low * 0100H Next * 0360H 
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B.U i 11 i n ; write nlow nhigh <f I I ename. typ> 
w nlow nhigh <fiIename.typ> 

Write a block of CP/M memory to a disk file. 

The bounds of the block to be written are specified by nlow and nhigh, 
which are numeric values as described at the start of this section. 

The specified block of memory is written from the CP/M Segment to the 
specified file. It is written as a pure memory image, unless a HEX 
extension is supplied. 

Specifying a filename of type .HEX will cause an Intel HEX file to be 
written. The final record of the generated HEX file is the special 
HEX record which specifies the starting execution address of the 
program. This address is assumed to be nlow. 
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Examp Ie: 

Z80 A>read 100 820init.com 

*** Low = 0100H Next = 0380H 

*** Z80 DMA, PC and Stack automatically set for .COM file 

Z80 A>write 100 360 820init.hex 

Writing HEX records for 0100H thru 0360H (609 bytes) to file 
'820INIT.HEX* 

Z80 A>read 820init.hex 

*** .HEX file Starting Address * 0100H 
*** Low = 0100H Next * 0360H 
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RuiI tin: submit <fiIename.typ> 
sub <fiIename.typ> 

Switches input (for Emulator commands only) to the specified file. 

This Is roughly equivalent to the CP/M SUBMIT.COM program, except that 
it is built into the Emulator. 

Z80 application input via BDOS and BIOS does not get switched. Only 
Emulator input is switched. Submit files cannot be nested. 

Input reverts to the standard input (as defined by PCDOS) when EOF is 
detected on the specified file. 

NOTE: If a keypress is detected during submit file processing 
but outside of Z80 operation (i.e. - when the Emulator is 
expecting a command), then the submit file is aborted. This 
Is how you cancel a submit file - just press SPACE while it 
is running. 

Examp Ie: 

Z80 A>submit script 

Z80 A>sub c:\cpm\autoexec.z80 


"Z80MU" Z80 and CP/M 2.2 Emulator User’s Guide Page 74 

BUILTIN COMMANDS: RESOURCE FACILITY COMMANDS 


Rui 11 i n : list [n1 [n2]] [>outfile | »out file] 

list prologue nl n2 [>outfile | »outfile] 
list include [A][0][F] 

I [nl [n2]] [>outfile | »outfile] 

I prologue nl n2 [>outf i I e | »outfile] 

I include [A][0][F] 

This is a multi-purpose disassembly command, which does one of three 
things (depending upon the arguments that are present): 

Lists disassembled Z80 object code (first form). 

Generates an assembler prologue for the given range of Z80 
object code (second form). 

Specifies fields to be included in disassembly lines (third 
form). 


Format: list [nl [n2l] [>outfile | »outfile] 

I [nl [n2j] [>outfile | »outfile] 


[continued) 
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through CP/M oddress n2*(both b of wh i ch^re -1 * 0 * C ? d ® fr ° m CF Y M oddress "1 
the stort of this section) If n2^i ?Z Mc o° Ues 08 defin#d <•* 

s^.a & - - -srg s b < 

asaai, 

i:v.7''r\:u:v: ° n,y *•«"'• »— * "S.. 
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finol oddress being jumped to Jot ie RST^, °k '"V ? r9Ument the 
Also, there is no END element sjpju e 3 ( ° S is ^*tomory). 
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Format: list prologue nl n2 [>outf!le | »outfilel 

I prologue nl n2 [>outfile | >>outfile] J 

front of o 9 Z80 r source S n'| 1 e! e The O generated SUitobl * for '"elusion at the 
for a given block of Z80 obiurt a source code is the prologue 

- - - 512 W 452 ; 2 'iBf.S 

char acters!*Add i t Iona* ly 0 "! t 'conta'i'ns^ea^t J h ? K° ri ° US ASCI1 contro1 

- ts-stk s? “ d isz ins'se'^ 

disassembly? 90 * '* 9en,r °" y "® eded at th * 'rent of any sizeable Z86 

file") the speci f ied^utput*? i 1 1° If^an^JtDut ?-. af> ? ended to (“»«ut- 
(no ">" character present 1 ! out P ut f,le 18 not specified. 

stoMord output », d.fl JV PCOM >° th ' 


Format: list include [A]TO 1fF1 

I Include [A][OJ[FJ 

Specifies the fields to be Included in disassembled Z80 instructions. 

feft^ofdisassembIed**nstructions?*^ ° ddreSSeS 1 ' b * •* the 

the^address°(?f""present) r but n before n the W Z 80 C mnemonIc! ^ ‘ nC,Uded °' ter 

”'Mn 7^l r rZl' n \ exp?a?nlng b the^instruct** mb '* d 280 

on the Z80 flags. P'oming the instruction’s possible effect(s) 

t; 9 che e cJe S d afUr ,,inC,Ud# ' , m ° y be word *- Only the first character 

In«t?u?t fon*w? 71 °con 27 «t f onTy"otf e ihJ*«A«i 2 n* * d 280 
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Examp Ie: 

Z80 A>list include addresses 

Z80 A>list include 

Z80 A>I prologue 100 7ff 

Z80 A>list prologue 0 ffff >mode1100.rom 

Z80 A> list 0 ffff »mode 1100. rom 

Z80 A>Iis t 


NOTE: The next section contains a sample Emulator session 
which generates source code from object code. Refer to it for 
more detail about this and related Resource commands. 
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RuiItin: control list [n] 
control clear 
control read <filepath> 
control write <filepath> 
control n i|b|w|t|s|c 

c list [n] 
c clear 

c read <fiIepath> 

c write <fiIepath> 

cn I | b | w | t | s | c 

This is a multi-purpose command which manipulates the disassembly 
control table. 

The disassembly control table holds CP/M addresses and any or all of the 
following which are associated with each address: 

The data type of the Z80 object code at this address. This is 
called a "control break". 

A symbolic label to be associated with the address. 

A comment to be associated with the address. 


This control table is used by the disassembler (the list command), and 
tells it how to format the source code while disassembling. 

The various data type control breaks that may be associated with a CP/M 
address are as follows: 

Instructions (executable Z80 code, disassembled as mnemonics) 

Bytes (disassembled as DB pseudo-ops) 

Words (disassembled as DW pseudo-ops, multiple entries per 
line) 

Table of Words (disassembled as DW pseudo-ops, one per line) 

Storage (disassembled as DS with argument large enough to 
bring it up to next control entry) 


This is how the disassembler knows which parts of your Z80 object code 
are instructions, which are data, and which are irrelevant buffers etc. 


{continued) 
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The specific formats are described below. 


Format: controI list [n] 
c list [n] 

This format of the command causes the Emulator to display all control 
table Information that Is currently known to It. If numeric value n (see 
definition of legal numeric values at start of this section) Is present, 
then only control Information associated with CP/M addresses greater 
than or equal to n are listed. 

The list includes any control breaks, labels, and comments associated 
with the various CP/M addresses. 


Format: control clear 
c cI ear 

This format of the command clears out the control table, so that nothing 
is known about the Z80 object code. No CP/M addresses, control breaks, 
labels or comments are defined after this command is given. 


Format: control read <filepath> 
c read <filepath> 

This format of the command causes the Emulator to read a control table 
from the specified filename. The file must have been created by a 
“control write <filepath>" command. 

A currently-defined control table is cleared before the new one is read 
from disk. It Is not possible to merge control tables using this 
command. 
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Format: control write <filepath> 
c write <fiIepath> 

This command writes the current control table to the specified file, for 
later input via the "control read <filepath>“ command. All known data is 
written - CP/M addresses, control breaks, labels and comments. 


Format: control n f | b | w | t | s | c 

cn i | b | w | t | s | c 

This format of the command is the real workhorse of control table 
maintenance. It associates a Z80 data type with CP/M address n, which is 

a numeric value as defined at the start of this section. 

The argument following CP/M address n is a directive to the disassembler 
(the list command), and may be any one of the following (note that only 
the first character is required): 

Instructions: switch to Z80 mnemonics when you get to this 
address. 

Bytes: switch to DB pseudo-ops when you get to this address. 

Words: switch to DW pseudo—ops (multiple per line) when you 
get to this address. 
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Table of words: switch to DW pseudo-ops (one per line) when 

you get to this address. This is useful for jump tables, 
etc, where you want the source code to be neatly ar¬ 
ranged . 

Storage: do a single DS (define storage) pseudo-op when you 
get to this address, and make the size field big enough 
to take you up to the next control break address (or the 
end of the disassembly, whichever is lower). 


You may also specify a special argument, which is handled immediately 
and never gets to the disassembler: 

Clear: Clear this address’s control break data type. This does 
not remove an associated label or comment. It just undoes 
any control break (of one of the above types) associated 
with this CP/M address. 
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Examp Ie: 

Z80 A>controI list 
Z80 A>c clear 

Z80 A>c read b:\model100\modeM00.ctl 

Z80 A>control write foo.ctl 

Z80 A>c read xyz 

Z80 A>control 100 Instructions 

Z80 A>c 103 b 

Z80 A>c tab Ie_start+1 S 

Z80 A>CONTROL bios_address W 

Z80 A>c FF00 Table 

Z80 A>c 103 clear 


NOTE: The next section contains a sample Emulator session 
which generates source code from object code. Refer to it for 
more detail about this and related Resource commands. 
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Bui 11in: label n [label_name] 
label autogen nl n2 
= n [label_name] 

■ autogen nl n2 

This command controls the assignment of symbolic label names to various 
CP/M addresses. Symbolic labels may be used as numeric values in many 
Emulator commands. They are also used by the disassembler when creating 
source code from Z80 object code. 


Format: label n [label_name] 

■ n [label_name] 

This format associates label_name with CP/M address n, which is a 
numeric value as described at the start of this section. 

Label names may be up to 32 characters in length. They must contain only 
alphanumeric characters and the underscore character 

If label_name Is absent in this command, then any existing label name 
associated with the specified CP/M address Is simply deleted. 


(continued) 
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Format: label autogen nl n2 

■ autogen nl n2 

This format causes the Emulator to automatically generate labels (of 
format AUTOxxxx) for all unlabeled CP/M addresses that are referenced by 
the block of Z80 code that starts at nl and ends at n2 (both of which 
are numeric values as defined at the start of this section). 

Labels that are generated are automatically entered into the current 
control table. Existing labels will not be altered. 

This is a quick way to create labels. It can be useful for rapid 
generation of readable source code from Z80 object code. You should, 
however, define any recognizable labels before using this command. You 
should also make sure that you have pretty accurately defined all 
control breaks that apply to the specified block of Z80 code. There’s 
nothing worse than getting a block of data confused with instructions, 
and having this command generate a few hundred bogus labels by misinter¬ 
preting the Z80 code. 
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So this Is generally the last thing that you do before deciding that 
you have finished disassembling a complete Z80 program. 


NOTE: 16-bit literals will be ignored. There’s no way - short 
of human inspection - to tell if the 16-bit value is meant to 
be a Z80 address or just a binary value (like a loop counter). 
In previous versions of the Emulator, there were too many 
bogus labels being autogen'd from 16-bit literals. Now it is 
up to you to decide whether a particular 16-bit literal 
should have a label associated with it. Specifically, the 
following instructions’ 16-blt literals are ignored: 


LD 

IX, 

, nn 

LD 

IY, 

,nn 

LD 

BC, 

,nn 

LD 

DE, 

,nn 

LD 

HL, 

, nn 

LD 

SP, 

,nn 


Examp Ie: 

Z80 A>= 100 program_entry 

Z80 A>label 7ff program_end 

Z80 A>» 0 warm_boot_jump 

Z80 A>= 5C FCB1 

Z80 A>« 5 BDOS 

Z80 A>!abel autogen 100 7ff 


NOTE: The next section contains a sample Emulator session 
which generates source code from object code. Refer to it for 
more detail about this and related Resource commands. 
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Bui 11in: comment n ["text"] 

; n ["text"] 

Associates source-code comment "text" with CP/M address n, which is a 
numeric value as defined at the start of this section, "text" may be up 
to 254 characters long. 
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If "text" is absent, then any existing comment associated with address n 
is simply deleted. 

Note that "text" must be enclosed in double quotes. It may include 
escape sequences as follows: 


\\ 

\0 

\b or \B 
\t or \T 
\n or \N 
\r or \R 

V 

V 

\xFF or \XFF 


Single "\" char 
NUL byte 
Backspace char 
Tab char 
Linefeed char 
Return char 
Single quote char 
Double quote char 
Byte with HEX value FF 


These escape codes made be used to make the comment more readable. 


When a comment is detected by the disassembler, it will be printed in 
one of two places: 

As a single-line comment, after the mnemonic. Such a comment 
replaces the flags comment field (if present). If "text" 
starts with other than a "\n" escape, then the comment is 
printed in this manner. 

As a multi-line comment, on lines before the instruction. If 
"text" starts with a "\n" escape, then the comment will 
be printed in this manner. Blank comment lines (starting 
with are automatically provided before and after the 

comment, and ";" characters are inserted after every "\n" 
or "\r" found in the "text" string. 


If you want to create a nice-looking multi-line comment, then imbed "\n" 
escapes as line delimiters, and "\t" escapes to line things up on 
succeeding Iines. 
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If your comment is intended to be a single-line comment appended to the 
disassembled instruction’s mnemonic, then avoid imbedded "\n" and "\r" 
escapes. 


Examp Ie: 

Z80 A>comment 100 "\nStart of main program" 

Z80 A>; 0 "Jump to BIOS Warm, Start" 

Z80 A>; 100 

Z80 A>comment ff00 "\nBIOS Jump Table\n\n\t3 bytes per JMP" 


NOTE: The next section contains a sample Emulator session 
which generates source code from object code. Refer to It for 
more detail about this and related Resource commands. 
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USING THE RESOURCE BUILTIN COMMANDS 


This section presents an example of re-sourcing a piece of Z80 object 
code. It demonstrates the use of the various Emulator builtln commands 
that deal with regenerating source code from object code. 


(continued) 
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We were recently presented with a piece of software which (wouldn't you 
know It?) existed only In object form on a Xerox 820 CP/M system. The 
owner of this little utility really wanted to move It to a 16-blt 
Hyperion system, cause the utility sets up a Z80 SIO and that's what the 
Hyperion has - an SIO. 

So he was wondering - could we regenerate the source code for this 
little beauty? What follows is on annotated record of the ensuing 
sessI on: 


NOTE: The first step is to read the thing into Z80 memory 
with the Emulator, and clear any previous resource control 
breaks. 

Z80 Oread 100 820inlt.com 
*** Low “ 0100H Next “ 0380H 

*** Z80 DMA, PC and Stack automatically set for .COM file 
Z80 Ocontrol clear 

Z80 C>list Include addresses opcodes 
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NOTE: The next thing to do is take a quick look at the 
program, and get a general feel for what it does. 


Z80 C>list 


L0100: 

L0103: 

L0106: 

L0109: 

L010C: 

L010F: 

L0111: 

L0114: 

L0116: 


NOTE: 
I ook 


11 

45 

02 

LD 

DE.L0245 

CD 

40 

02 

CALL 

L0240 

11 

C8 

02 

LD 

DE,L02C8 

CD 

40 

02 

CALL 

L0240 

CD 

35 

02 

CALL 

L0235 

FE 

0D 


CP 

CR 

C2 

16 

01 

JP 

NZ.L0116 

3E 

36 


LD 

A, ’6’ 

D6 

30 


SUB 

’0’ 

This 

isn’t real 

promising. 

Let’s dump 


for obvious ASCII strings. 


Z80 C>d 100 37f 


ADDR 00 01 02 03 04 05 06 07 08 09 


0100: 11 45 02 CD 40 02 11 C8 02 CD 

0110: 0D C2 16 01 3E 36 D6 30 FE 00 

0120: 06 01 32 58 03 11 EF 02 CD 40 

0130: C2 35 01 3E 4E FE 45 CA 47 01 

0140: 4E CA 47 01 C3 25 01 32 5A 03 

0150: CD 35 02 FE 00 C2 5A 01 3E 38 

0160: 01 FE 08 CA 69 01 C3 4A 01 32 

0170: 00 C2 79 01 3E 0F C3 B7 01 FE 

0180: C3 B7 01 FE 02 C2 8D 01 3E 0C 

0190: 97 01 3E 0A C3 B7 01 FE 04 C2 

01A0: 01 FE 05 C2 AB 01 3E 06 C3 B7 

01B0: 3E 05 C3 B7 01 3E 02 32 58 03 

01C0: C7 01 3E 03 C3 03 01 FE 4F C2 

01D0: 01 3E 00 32 5A 03 3A 59 03 FE 

01E0: 32 5B 03 3E C0 32 5C 03 C3 F5 

01F0: 3E 40 32 5C 03 F3 3E 18 D3 06 

0200: AF D3 06 3E 04 D3 06 3A 5A 03 

0210: D3 06 3A 5C 03 C6 01 03 06 3E 

0220: C6 8A D3 06 3E 47 D3 00 3A 58 

0230: 03 CD 40 02 C9 0E 01 CD 05 00 

0240: 0E 09 C3 05 00 1A 49 4E 49 54 

0250: 6F 72 20 58 65 72 6F 78 20 38 

0260: 0D 0A 42 61 75 64 20 52 61 74 

0270: 39 32 30 30 20 3D 20 30 00 0A 


0A 0B 0C 0D 0E 0F 01234567 89ABCDEF 


40 02 CD 35 02 FE .E.M@..H ,M®.M5.~ 

DA 06 01 FE 0A 02 .8..>6V0 ~.Z..~.R 

02 CD 35 02 FE 0D ..2X..O. M@.M5.~. 

FE 4F CA 47 01 FE 85.>N~EJ G.~OJG.~ 

11 16 03 CD 40 02 NJG.CX.2 Z M@. 

D6 30 FE 07 CA 69 M5.~.BZ. >8V0~.Ji 

59 03 3A 58 03 FE .-.Ji.CJ .2Y.:X.~ 

01 C2 83 01 3E 0E .By.>.C7 .~.B..>. 

C3 B7 01 FE 03 C2 C7.-.B.. >.C7.~.B 

A1 01 3E 07 C3 B7 ,.>.C7.~ ,B!.>.C7 

01 FE 06 C2 B5 01 .~.B+.>. C7.~.B5. 

3A 5A 03 FE 45 C2 >.C7.>.2 X.:Z.~EB 

D1 01 3E 01 C3 D3 G.>.CS.~ 0BQ.>.CS 

07 CA EB 01 3E 60 .>.2Z.:Y .~.Jk.>‘ 

01 3E 20 32 5B 03 2[.>@2\. Cu.>2[. 

D3 06 3E 01 D3 06 >@2\.s>. S.S.>.S. 

C6 44 D3 06 3E 03 /S.>.S.: Z.FDS.>. 

05 D3 06 3A 58 03 S.:\.F.S .>.S.:[. 

03 D3 00 FB 11 3D F.S.>GS. :X.S.}.- 

FE 60 D8 D6 20 C9 ,M@.I..M ..~'XVI 

20 31 2E 30 20 66 ..C...IN IT 1.0f 

32 30 00 0A 0A 0A or Xerox 820- 

65 73 3A 00 0A 31 ..Baud R otes:..1 

39 36 30 30 20 20 9200 = 0 ..9600 
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0280: 3D 

20 

31 

0D 

0A 

34 

38 

30 

30 

20 

20 

3D 

20 

32 

0D 

0A 

= 1..480 

0 * 2.. 

0290: 32 

34 

30 

30 

20 

20 

3D 

20 

33 

0D 

0A 

31 

32 

30 

30 

20 

2400 = 

3. .1200 

02A0: 20 

3D 

20 

34 

0D 

0A 

20 

36 

30 

30 

20 

20 

3D 

20 

35 

0D 

- 4.. 6 

00 « 5. 

02B0: 0A 

20 

33 

30 

30 

20 

20 

3D 

20 

36 

0D 

0A 

20 

31 

31 

30 

. 300 = 

6.. 110 

02C0: 20 

20 

3D 

20 

37 

0D 

0A 

24 

0D 

0A 

53 

65 

6C 

65 

63 

74 

= 7..$ 

..Se1ect 

02D0: 20 

62 

61 

75 

64 

20 

72 

61 

74 

65 

20 

20 

20 

20 

20 

20 

baud ra 

te 

02E0: 20 

20 

20 

20 

20 

28 

31 

2D 

39 

29 

3A 

20 

36 

08 

24 

0D 

(1- 

9): 6.$. 

02F0: 0A 

53 

65 

6C 

65 

63 

74 

20 

70 

61 

72 

69 

74 

79 

20 

20 

.Se1ect 

pari ty 

0300: 28 

4F 

64 

64 

2C 

20 

45 

76 

65 

6E 

2C 

20 

4E 

6F 

6E 

65 (Odd, Ev 

en, None 

0310: 29 

3A 

20 

4E 

08 

24 

0D 

0A 

53 

65 

6C 

65 

63 

74 

20 77 ): N.$.. 

Select w 

0320: 6F 

72 

64 

20 

6C 

65 

6E 

67 

74 

68 

20 

20 

20 

20 

20 

20 

ord leng 

th 

0330: 28 

37 

20 

6F 

72 

20 

38 

29 

3A 

20 

38 

08 

24 

0D 

0A 43 (7 or 8) 

: 8.$..C 

0340: 6F 

6D 

6D 

75 

6E 

69 

63 

61 

74 

69 

6F 

6E 

73 

20 

70 

6F 

ommunica 

tions po 

0350: 72 

74 

20 

73 

65 

74 

2E 

24 

00 

00 

00 

00 

00 

00 

00 

00 

rt set.$ 

0360: 00 

00 

00 

00 

00 

00 

00 

00 

00 

00 

00 

00 

00 

00 

00 

00 



0370: 00 

00 

00 

00 

00 

00 

00 

00 

00 

00 

00 

00 

00 

00 

00 

00 




NOTE: Well, there are some strings that are terminated with 
dollar signs. This is a heavy hint that these strings are to 
be displayed by BDOS function 9. Let’s start our control 
table by filling in what we know so far... 


Z80 

C>c 

100 

1 nstructions 

(0100h 

. of 

course, starts code) 

Z80 

C>- 

100 

startup 

(Give 

it a 

sensible name) 

Z80 

C>c 

245 

b 

(Start 

bytes at first ASCII string) 

Z80 

C>« 

245 

Init_msg 

(Give 

them 

sensible names) 

Z80 

C>» 

2c8 

baud_prompt 




Z80 

C>« 

2ef 

par 1ty_prompt 




Z80 

c>« 

316 

datab1ts_prompt 




Z80 

c>- 

33d 

wrapup_msg 
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NOTE: Now let’s look at the first code bytes again, and see 
If they make any more sense. 

Z80 C>l 100 


STARTUP: 


L0100 

11 

45 

02 

LD 

DE,INIT_MSG 

L0103 

CD 

40 

02 

CALL 

L0240 

L0106 

11 

C8 

02 

LD 

DE,BAUD_PROMPT 

L0109 

CD 

40 

02 

CALL 

L0240 

L010C 

CD 

35 

02 

CALL 

L0235 

L010F 

FE 

0D 


CP 

CR 

L0111 

C2 

16 

01 

JP 

NZ,L0116 

L0114 

3E 

36 


LD 

A, ’6’ 

L0116 

D6 

30 


SUB 

’0’ 


(continued) 
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NOTE: So the routine at 0240h does something with a "{"- 
terminated string. Need we guess? 


Z80 C>l 

240 



L0240: 

0E 

09 

LD C,TAB 

L0242: 

C3 

05 00 

JP L0005 



INIT_MSG: 




DB 

SUB,"INIT 1.0 for Xero" 

L0245: 

1A 

49 4E 49 


L0249: 

54 

20 31 2E 


L024D: 

30 

20 66 6F 


L0251: 

72 

20 58 65 


L0255: 

72 

6F 



NOTE: First of all, note how the above disassembly changed 
from instructions to data. Just as we told it to. Note also 
that this routine at 0240h is simple enough to document... 

Z80 C>* 5 bdos 

Z80 C>; 240 "\nPrlnt {-terminated string at (DE) M 
Z80 Oc 240 i 
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Z80 C>« 240 print_string 
Z80 C>l 240 


PRINT_STRING: 


Print {-terminated string at (DE) 


L0240: 

0E 

09 

LD 

C,TAB 

L0242: 

C3 

05 00 

JP 

BDOS 



INIT_MSG: 





DB 

SUB,"INIT 

1.0 for Xero" 

L0245: 

1A 

49 4E 49 



L0249: 

54 

20 31 2E 



L024D: 

30 

20 66 6F 



L0251: 

72 

20 58 65 



L0255: 

72 

6F 




NOTE: OK, one routine down. Referring back to our disassembl 
of the startup code, let’s see what else we can figure out. 

Z80 C>= 106 get_baud_rate 

Z80 C>l startup 


STARTUP: 


L0100: 

11 

45 02 

LD 

DE,INIT MSG 

L0103: 

CD 

40 02 

CALL 

PRINT_STRING 



GET_BAUD_RATE: 



L0106: 

11 

C8 02 

LD 

DE,BAUD_PROMPT 

L0109: 

CD 

40 02 

CALL 

PRINT_STRING 

L010C: 

CD 

35 02 

CALL 

L0235 

L010F: 

FE 

0D 

CP 

CR 

L0111: 

C2 

16 01 

JP 

NZ,L0116 

L0114: 

3E 

36 

LD 

A,'6* 

L0116: 

D6 

30 

SUB 

’0* 
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Z80 C>l 235 


L0235 

L0237 

L023A 

L023C 

L023D 

L023F 


L0240: 
L0242: 


L0245: 
L0249: 


D8 

D6 

C9 


have another 

routine to 

dec i phei 

01 

LD 

C, SOH 

05 00 

CALL 

BDOS 

60 

CP 

9 9 9 


RET 

c 

20 

SUB 

• * 


RET 



PRINT_STRING: 

Print $-terminated string at (DE) 


0E 09 
C3 05 00 

INIT.MSG: 

DB 

1A 49 4E 49 
54 20 31 


LO 

JP 


C.TAB 

BDOS 


SUB,"INIT 1“ 


NOTE: Notice how the disassembly continued way past the end 
of our routine. That's because we didn't give an ending 
address. At any rate, the routine at 0235h appears to call 
BDOS to get a keypress, then force it to uppercase. It 
contains a slight bug, but our job right now is to re-source 
it, not fix it. 

Z80 C>» 235 get_bdos.keypress 
Z80 C>c 235 i 

Z80 C>; 235 "\nReturn next keypress as Uppercase char in A-reg" 
Z80 C>; 237 "Use BDOS to get next keypress" 

Z80 C>; 23a "Is it lowercase char?" 

Z80 C>; 23c "No, return it as-is" 

Z80 C>; 23d "Yes, convert to uppercase" 
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Z80 C>l 235 


GET.BDOS.KEYPRESS: 


Return next keypress as Uppercase char in A-reg 


L0235: 

0E 01 

LD 

C.SOH 


L0237: 

CD 05 00 

CALL 

BDOS 

;Use BDOS to get next 





keypress 

L023A: 

FE 60 

CP 

•«• 

; I s It lowercase char? 

L023C: 

D8 

RET 

C 

;No, return it as-is 

L023D: 

D6 20 

SUB 

• • 

;Yes, convert to uppercase 

L023F: 

C9 

RET 




(continued) 
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PRINT_STRING: 


; Print $-termInated string at (DE) 

L0240: 0E 09 LD C,TAB 

L0242: C3 05 00 JP BDOS 

INIT_MSG: 

DB SUB,"INIT 1” 

L0245: 1A 49 4E 49 

L0249: 54 20 31 


NOTE: OK, our little routines are understood and documented. 
Back to the main code, and add comments that clarify things. 


Z80 

C>; 

100 

"Give 

I nt 

ro screen 

i" 

Z80 

C>; 

106 

"Ask 

for 

baudrate 

va 1 ue 

Z80 

C>; 

10 f 

"RETURN only?" 


Z80 

C>; 

111 

"No, 

1 ook 

at keypr 

ess" 

Z80 

C>; 

114 

"Yes, 

use 

defau1t 

va 1 ue 

Z80 

C>» 

116 

edit. 

.baud, 

_rate 
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Z80 C>l get_baud_rate 12b 


GET_BAUD_RATE: 


L0106: 

11 

00 

o 

02 

LD 

L0109: 

CD 

40 

02 

CALL 

L010C: 

CD 

35 

02 

CALL 

L010F: 

FE 

0D 


CP 

L0111: 

C2 

16 

01 

JP 

L0114: 

3E 

36 


LD 





EDIT.BAUD. 

.RATE: 

L0116 

D6 

30 


SUB 

L0118 

FE 

00 


CP 

L011A 

DA 

06 

01 

JP 

L011D 

FE 

0A 


CP 

L011F 

D2 

06 

01 

JP 

L0122 

32 

58 

03 

LD 

L0125 

11 

EF 

02 

LD 

L0128 

CD 

40 

02 

CALL 

L012B 

CD 

35 

02 

CALL 


DE,BAUD.PROMPT ;Ask for baudrate 

va I ue 

PRINT.STRING 

GET_BDOS_KEYPRESS 

CR ;RETURN only? 

NZ, ED I T_BAUD_RATE ;No, look at 

keypress 

A,'6* ;Yes, use default 

va I ue 


’ 0 ’ 

NUL 

C,GET_BAUD_RATE 

LF 

NC.GET_BAUD_RATE 

(L0358),A 

DE,PARITY.PROMPT 

PRINT_STRING 

GET_BDOS_KEYPRESS 


NOTE: And so on, and so on, and so on.... 


We’ll not present all of the output here. Although the session actually 
lasted less than half an hour, the output is huge. Instead, let us skip 
ahead to the point where we’ve finished defining our control table. 


152 BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 








October 


NOTE: At this point - having done all of this work to con¬ 
struct documentation of the object code - we should save the 
control.table to diski 

Z80 C>control write 820?nit.c11 
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NOTE: Having done that, we must prepare things for the actual 
generation of the .ASM file. Specifically, we should exclude 
addresses, opcodes, and flags from disassembly source lines. 

Z80 C>list incIude » 


NOTE: Now we can disassemble the object code to disk as source 
code. First we write the prologue, and then the program 
i tseIf: 

Z80 C>list prologue 100 360 >820init.asm 
Z80 C> I i st 100 360 »820 i n i t. asm 


NOTE: Having done that, let's test things by running the .ASM 
file through M80.COM... 

Z80 C>m80 820init.re I,820init.prn=820init.asm 
%No END statement 
%No END statement 

No Fatal error(s) 


That’s it. We're done. The assembler version of 820INIT.COM has been 
wr I tten and verified. 

For your enjoyment, we have included with Z80MU the various 820INIT 
files that were used or created by the above session. Feel free to 
examine all of these files, especially 820INIT.ASM and 820INIT.PRN. They 
give you a good Idea of the quality of source code that can be recreated 
from a given object program. 
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Appendix A: Layout of Simuloted CP/M Segment fas set bv Cold Boot 1 ) 


0000 

JMP 

0FF03H 

;to our fake BIOS 


0003 

DB 

? 

;IOBYTE 


0004 

DB 

? 

;Login Byte (drive, User 

Number) 

0005 

JMP 

0FEFEH 

;to our fake BDOS 


005C 

DB 

? 

;Defau1t FCB 


0080 

DB 

? 

•.Default DMA and Command 

Tai 1 

0100 

DB 

? 

;start of TPA 


FEFD 

DB 

? 

; last byte of TPA 


FEFE 

HALT 


;our BDOS hook 


FEFF 

RET 


;return from BDOS 


FF00 

JMP 

0FF80H 

;BIOS COLD BOOT vector 


FF03 

JMP 

0FF82H 

;BI0S WARM BOOT vector 


FF06 

JMP 

0FF84H 

;BI0S console status 


FF09 

JMP 

0FF86H 

;BI0S console input 


FF0C 

JMP 

0FF88H 

;BI0S console output 


FF0F 

JMP 

0FF8AH 

;BIOS list output 


FF12 

JMP 

0FF8CH 

;BI0S punch output 


FF15 

JMP 

0FF8EH 

;BIOS reader input 



( continued ) 
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FF18 

JMP 0FF90H 

BIOS home disk 

FF1B 

JMP 0FF92H 

BIOS select disk 

FF1E 

JMP 0FF94H 

BIOS set track 

FF21 

JMP 0FF96H 

BIOS set sector 

FF24 

JMP 0FF98H 

BIOS set DMA address 

FF27 

JMP 0FF9AH 

BIOS read sector 

FF2A 

JMP 0FF9CH 

BIOS write sector 

FF2D 

JMP 0FF9EH 

BIOS 

list status 

FF30 

JMP 0FFA0H 

BIOS 1 

funimp 1emented) 

FF33 

JMP 0FFA2H 

BIOS 1 

fun imp 1emented) 

FF36 

JMP 0FFA4H 

BIOS 1 

(unimp 1emented) 

FF39 

JMP 0FFA6H 

BIOS 1 

funImplemented) 

FF3C 

JMP 0FFA8H 

BIOS 1 

funimplemented) 

FF3F 

JMP 0FFAAH 

BIOS 1 

funimplemented) 

FF42 

JMP 0FFACH 

BIOS 1 

funimp1emented) 

FF45 

JMP 0FFAEH 

BIOS 1 

funimp1emented) 

FF48 

JMP 0FFB0H 

BIOS \ 

funimplemented) 

FF4B 

JMP 0FFB2H 

BIOS { 

fun imp 1emented) 

FF4E 

JMP 0FFB4H 

BIOS ( 

fun Imp 1emented) 

FF51 

JMP 0FFB6H 

BIOS I 

fun imp 1emented) 

FF54 

JMP 0FFB8H 

BIOS ( 

fun imp 1emented) 

FF57 

JMP 0FFBAH 

BIOS ( 

fun Imp 1emented) 

FF5A 

JMP 0FFBCH 

BIOS ( 

fun Imp 1emented) 

FF50 

JMP 0FFBEH 

BIOS < 

funimp 1emented) 

FF60 

JMP 0FFC0H 

BIOS ( 

fun Imp 1emented) 

FF63 

JMP 0FFC2H 

BIOS ( 

funimp1emented) 

FF66 

JMP 0FFC4H 

BIOS ( 

fun imp 1emented; 
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FF 69 

JMP 0FFC6H 

;BIOS 

1 

fun Imp 1emented) 

FF6C 

JMP 0FFC8H 

; BIOS 

1 

fun Imp1emented) 

FF6F 

JMP 0FFCAH 

; BIOS 

1 

fun imp 1emented) 

FF72 

JMP 0FFCCH 

;BIOS 

\ 

funimp1emented) 

FF75 

JMP 0FFCEH 

; BIOS 

i 

funimp1emented) 

FF78 

JMP 0FFD0H 

; BIOS 

1 

funImp1emented) 

FF7B 

JMP 0FFD2H 

; BIOS 

1 

fun 1mp1emented) 

FF80 

HALT 

; BIOS 

COLD BOOT hook 

FF81 

RET 




FF82 

HALT 

;BIOS 

WARM BOOT hook 

FF 83 

RET 




FF84 

HALT 

;BIOS 

console status 

FF85 

RET 




FF86 

HALT 

;BIOS 

console input 

FF87 

RET 




FF88 

HALT 

; BIOS 

console output 

FF89 

RET 




FF8A 

HALT 

; BIOS 


1ist output 

FF8B 

RET 




FF8C 

HALT 

;BIOS 

punch output 

FF8D 

RET 




FF8E 

HALT 

;BIOS 

reader input 

FF8F 

RET 




FF90 

HALT 

; BIOS 

home disk 

FF91 

RET 




FF 92 

HALT 

;BIOS 

select disk 

FF93 

RET 




FF94 

HALT 

; BIOS 

set track 

FF 95 

RET 




FF 96 

HALT 

; BIOS 

set sector 

FF97 

RET 




FF98 

HALT 

; BIOS 

set DMA address 

FF 99 

RET 




FF9A 

HALT 

;BIOS 

read sector 

FF9B 

RET 




FF9C 

HALT 

; BIOS 

write sector 

FF9D 

RET 




FF9E 

HALT 

; BIOS 

list status 

FF9F 

RET 




FFA0 

HALT 

; BIOS 

(unimp 1emented) 

FFA1 

RET 




FFA2 

HALT 

;BIOS 

(unImp1emented) 

FFA3 

RET 
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FFA4: 

HALT 

;BIOS 

(unimp 1emented) 

FFA5: 

RET 



FFA6: 

HALT 

;BIOS 

(unimp 1emented) 

FFA7: 

RET 
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FFA8 

HALT 

;BIOS 

(unimp1emented) 

FFA9 

RET 



FFAA 

HALT 

;BIOS 

(unimp1emented) 

FFAB 

RET 



FF AC 

HALT 

;BIOS 

(unimp1emented) 

FFAD 

RET 



FFAE 

HALT 

;BIOS 

(unimp1emented) 

FF AF 

RET 



FFB0 

HALT 

;BIOS 

(unimp 1emented) 

FFB1 

RET 



FFB2 

HALT 

;BIOS 

(unimp 1emented) 

FFB3 

RET 



FFB4 

HALT 

;BIOS (unimp 1emented) 

FFB5 

RET 



FFB6 

HALT 

;BIOS 

(unimp 1emented) 

FFB7 

RET 



FFB8 

HALT 

;BIOS 

(unimp 1emented) 

FFB9 

RET 



FFBA 

HALT 

; BIOS 

(unimp 1emented) 

FFBB 

RET 



FFBC 

HALT 

;BIOS 

(unimp 1emented) 

FFBD 

RET 



FF BE 

HALT 

; BIOS 

(unimp1emented) 

FFBF 

RET 



FFC0 

HALT 

-.BIOS 

(unimp 1emented) 

FFC1 

RET 



FFC2 

HALT 

; BIOS 

(unimp1emented) 

FFC3 

RET 



FFC4 

HALT 

;BIOS 

(unimp 1emented) 

FFC5 

RET 



FFC6 

HALT 

; BIOS 

(unimp 1emented) 

FFC7 

RET 



FFC8 

HALT 

;BIOS 

(unimp 1emented) 

FFC9 

RET 



FFCA 

HALT 

; BIOS 

(unimp1emented) 

FFCB 

RET 



FFCC 

HALT 

; BIOS 

(unimp 1emented) 

FFCD 

RET 



FFCE 

HALT 

;BIOS 

(unimp 1emented) 

FFCF 

RET 



FFD0 

HALT 

; BIOS 

(unImp1emented) 

FFD1 

RET 



FFD2 

HALT 

;BIOS 

(unimp 1emented) 

FFD3 

RET 



FFD4 


; rest 

reserved for scratch 
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Appendix B: Bugs and Future Plans 


This section describes known bugs and otherwise strange Emulator 
activity. Please help us to improve the product by sending us your own 
bug reports, with as much detail as possible (Including programs 
which demonstrate the bug). 


(continued) 
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These bugs will be fixed as time allows and user Interest demands. 


Issue: The disassembly (list) command can become quite pokey. 
As the control table grows, disassembly speed decreases. 
When disassembling the Model 100’s ROM, for instance, the 
poor disassembler is faced with a control table that Is 
something bigger than 42K in size. It may have to 
search most of the table for each memory reference. This 
yields a disassembly speed of a line or two a second. 

Bool The control table search routines should be changed 
from a sequential to an indexed method. 

Author’s Response: Agreed. Will rewrite these for a future 
re I ease. 


Issue: Some commands (notably those that accept a range of 
CP/M addresses) get confused if they are asked to wrap 
around the high end of the 64K CP/M segment. 


Author’s Response: Have applied 
problems. Would appreciate 
commands fail, and how) to 


Issue: Internal I/O redirection 
PCDOS) should be available 
just the Iist command. 

Author’s Response: Agreed. Will 


fixes for most glaring 
specifics (l.e. - which 
help track down the rest. 


(effected by the Emulator, not 
for any Emulator command, not 


look into It. 
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Issue: The patch command ought to allow multiple entries per 
line, and ought to accept arguments on the patch command 
line without dropping into interactive patch mode. 

Author's Response; Have provided left-handed solution by 

allowing a patch string on same line as patch command. 
True fix (with multiple byte values as independent args 
on command line) will take a while to implement. 


Issue; The Emulator lacks a mini assembler. It needs one. 

Authors Response;. Agreed. We just don’t have the memory left 
in the 64K Lattice code segment to do it right. Maybe 
after some major rework... 


I ssue; The Emulator's main program ought to be rewritten in 
Microsoft C version 3.0. This will speed It up consider¬ 
ably, and will make it a lot smaller. 

Author’s Response; Agreed. The major effort is in reworking 
the assembler subroutines. There are a lot of places 
where Lattice’s calling conventions, register usage, and 
segments are assumed. 


I ssue; , It would be nice to somehow state to the Emulator that 
what is in CP/M memory is actually an 8080 or 8085 
program. This would allow the 8085’s RIM and SIM Instruc¬ 
tions, for example, to be properly disassembled (instead 
of being misinterpreted as Z80 relative jumps). 

Author’s Response; Agreed. The biggest obstacle to doing this 
is the same old bugaboo - no memory left in 64K code 
segment. Will put this off until we free up a couple of 
K in the code segment. 
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Issue: The loading of Z80 .COM files to be executed - in fact, 
any file load that is done directly or indirectly by the 
"read" command - is just too slow. 

Author’s Response: Agreed! This should be redone to bypass 

Lattice C’s slow I/O routines. This problem may go away 
if and when the Emulator is rewritten in Microsoft *C* 
version 3.0. 


Issue : The disassembler can get confused when a multi-byte 
opcode crosses a control break. In general, it reverts 
to DB pseudo ops up to the control break when this 
happens. Also, it’s not too smart when disassembling 
code with addresses up around the 64K segment boundary. 

Author’s Response: I have tried to locate and eliminate 

peephole problems. The nature of the problem, however, 
goes to the very core of the disassembler as designed. 
This is not quickly (or cheaply) fixable. 


Issue: There are too many CP/M applications which abort 

because they use BDOS functions 27/1Bh and 31/1Fh. These 
BDOS functions should be supported, even if they mean 
little on a PCDOS system. 

Author’s Response: Agreed. The only reason that they haven’t 
been emulated is that I have yet to find a sensible 
writeup of just exactly what the various data formats 
are. DRI’s writeup stinks. If someone can provide a 
clear explanation of just what they truly mean, then 
I’ll emu late them. 


Issue : There are more than 600 distinct instructions in the 
Z80. Have they all been validated as to the accuracy of 
the emulation? 

Author’s Response: So far, all we’ve done is run Z80 stuff and 
try to guess that it has run fine. All opcodes have been 
desk-checked. Not all opcodes have been tested. Most, in 
fact, have not even been executed. Would somebody please 
create a definitive test program? The diagnostics that 
we've tried (like Supersoft’s) have proven to be inac¬ 
curate. 
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Issue : There should be an option to allow pagination of 
disassembled object code. 

Author’s Response: Agreed. Will look into another list include 
option to specify pagination. 


Issue : Expressions are currently limited to " + " and 

operators. They should allow and "/" also, and maybe 
even AND, OR, XOR, shifts, etc. 

Author’s Response: I disagree. The amount of work involved 
Isn't justified by the benefit. 


Issue: The Z80 IN and OUT instructions should have access to 
real 8088 I/O ports on the IBM PC. 

Author’s Response: Over my dead body. 


[continued ) 
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Issue ; FCB+14 and FCB+15 aren’t emulated properly. This keeps 
certain Microsoft-written subroutines from running. 

Author's.Response; This has been fixed in release 2.1b, by 
censoring PCDOS’s use of these bytes. 


Issue: LU version 3.00 fails. 

Author's Response; LU expects BOOS results to come back in 
HL, not A. This is an undocumented facet of CP/M, but 
every version of CP/M that I tested does indeed return 
results In HL as well as A. Fixed In Emulator release 
3.00 to return results in HL and A. Tested with LU, and 
It works fine. 


Issue; Some packages do full-screen I/O via BOOS, thus 

missing the built-in VT52 emulator (which only responds 
to BIOS cal Is). 

Author's Response; Fixed. See the new "terminal" command, 
which allows you to control who (BIOS or BDOS) goes 
through the VT52 emulator. 
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Issue ; Clearing a single breakpoint causes the wrong one to 
be removed. 

Author's Response; In improving the "break" command, I broke 
this part of it. It is now fixed. 


Issue; Disassembler unreliable In version 3.00. 

Author's Response; Due to a mistake made when compiling 

version 3.00, we broke parts of the disassembler. It is 
fixed in version 3.10. 


IS-Sue.; Serial I/O via PCDOS is too slow! How about a full¬ 
screen version of the Emulator? 

Author's Response; This is being developed, along with the 
port to Microsoft C version 3.0. 


Issue;. The Label AUTOGEN commands hangs if the ending address 
is 0FFFFh. * 

Author's Response; Will be corrected In first Microsoft C 

version 3.0 copy of the Emulator, as this is due to a bug 
In Lattice C and I’ve fixed enough Lattice bugs for one 
lifetime. 


Issue; BDOS Function 10/0Ah (read buffered console input) 

doesn't work like it does in CP/M. You must press RETURN 
before input is terminated. 

Author 'S Response; This has been fixed in release 3.10. This 
BDOS function is now entirely emulated by the Z80 engine 
Formerly, we just called PCDOS to do it. 


Issue; The stack does not contain a word of zeroes when a 
.COM program is entered. 
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Author’s Response: The stack pointer is set to FEFC. A word 
of zeroes is then stored there via: 

cpm[0xfefcl * 0; /* Put word of zeroes */ 

cpm[0xfefd] ■ 0; 

Lattice C, however, takes the hex literals as signed 
Ints, and stores our zeroes into who knows where. This 
is all the more reason to dump this bad C compiler and 
move to Microsoft v3.0 C. Anyway, the zero word is now 
on the stack in version 3.10. 


Issue: The Emulator’s VT52 terminal uses ESC F to clear the 
screen. This isn’t what a real VT52 uses. 

Author’s Response: Fixed in release 3.10 to use ESC E. The Ze¬ 
nith Z-89 manual used as the VT52 reference contained a 
typo, and I coded from it. 

COMPUTERWISE CONSULTING SERVICES, P.0. BOX 813, MCLEAN, VA 22101 


CONDRV.DOC 

"Enhanced Console Driver," by Anthony Zackin, October 1986, page 183. 


t******************************************************************************* 

Enhanced Console Device Driver, Copyright (c) 1986 Anthony Zackin 

The syntax of the Enhanced Console Device Driver commands is similar to the DOS 
extended screen and keyboard control functions defined in the DOS Technical 
Reference Manual. The functions defined here are somewhat more complex since 
the data sent to the driver must consist of a set of operations and strings to 
enable the creation of the screen display buffer. The basic syntax is: 

Esc[{operation-string}: 

where ’Esc’ represents the escape character, ASCII 27 (hexadecimal IB), and 
{operation-string} typically consists of a one-byte operation code (op) 
possibly followed by an attribute, one or more sets of row/column coordinates, 
and perhaps a string to be placed in the buffer. The op codes may have several 
variants which are created by adding 128, 64, 32, etc. to the base value defined 
below. 

When the Enhanced Console Driver has been installed at system boot time (by a 
’DEVICE-CONDRVxx.SYS' entry in the CONFIG.SYS file) all console output displayed 
via DOS will be examined for the escape sequences defined below. If a legal one 
is found the appropriate operation is performed. 


op=0 - Display a window from the current screen buffer (modifier * 128). 

Esc[0;{frow};jfcol};{trow};{tcoI};{srow};{scoI}: 

Esc[128;{window};{frow};{fcoI};{trow};{tcoI};{srow};{scoI}: 

- displays an explicitly defined window ({frow},{fcoI}) through 

({trow}.{tcol}) of the current buffer; if any of the row or column values 
are omitted then the current default values are used (set by Esc[1 ... or 
by builtin defaults, normally, 1,1,25,80,1,1); if row/column values are 
specified then row/column values to their left may not be omitted 

- all arguments are optional 

- row 1, column 1 corresponds to the upper left-hand corner of the screen 

- {frow};{fcoI} (1,1) * starting (from) row,col of the window in the 
screen buffer 

- {trow};{tcol} (1,MAXC0L) - ending (to) row,col of the window in the 
screen buffer 

(continued) 
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- MAXCOL « 80 when MODE 80 is in effect, 40 when MODE 40 is in effect 

- row/coIumn coordinotes define a ’window’ to display, not necessarily 
contiguous characters 

- if frow,fcoI - 4,21 and trow.tcol - 8,60 then only columns 21 through 
throuah 60 inclusive of rows 4 through 8 inclusive will be displayed 

- {srow};{scoI } (1.1) * starting row,col in the display adapter memory to 
which the window defined above in the screen buffer is moved 

- initial defaults are in parentheses above 

- if op+128 Is specified then a window number between 0 and 3 must be 
specified as the first argument; window 0 is assumed otherwise 

- each screen buffer may have up to four predefined windows which may 
be displayed solely by referring to the window number 

- any supplied arguments will override the corresponding predefined 
vaIues 

- Esc[; - Esc[0: 

- this sequence is all that is needed to display the currently defined 
screen buffer; for example, via a program such as DEFKEY (see below) 
use Esc[1 ... to define the default window to be displayed and its 
location on the screen and then display it via a PROMPT, e.g., PROMPT 


- Example: 

Esc[0;1;1;5;10;21;1: 

- displays the window from row 1, column 1 to row 5, column 10 at 
screen location » row 21, column 1; the default window and screen 
location values remain unchanged 

Esc[: or Esc[0: 

- this will display window number 0 from the currently selected buffer 
Esc[128;3: 

- this will display window number 3 from the currently selected buffer 

op s 1 - Same as op=0 except that the window is not displayed but rather the 
defaults for the next display are reset. This permits one program to define a 
buffer and another to display whatever has been defined. (Modifier - 128). 

EscM;{f row};|f coI};{trow};{tool};{srow};{scol}: 

Esc[129;{window};{frow};{fcol};{trow};{tcol};{srow} ;{scoI}: 

- defines the default window parameters for the current window, from 
({frow},{fcoI}) through ({trow},{tcoI}) in the current buffer to 

({srow},{scoI}) on the screen 

- no data are displayed 

- Example: 

Esc[1;1;1;5;10;21;1: 

- resets window number 0 defaults 

- data to be displayed will come from row 1, column 1 to row 5, 
column 10 of the current buffer 

- display will start at screen location * row 21, column 1 

- note that one or more of these defaults may be temporarily 
overridden by an Esc[0 ... with row/column values specified 

Esc[129;3;1;1;5;10;21;1: 

- resets window number 3 defaults for the current screen buffer 

op=2 - Locate a string within the current screen buffer at a specified row and 
column; all characters in the string will be given the specified attribute 
({attr}) or will use the currently set default value if {attr} is not specified. 
(Modifiers » 128, 64, and 32. The op modifiers are not mutually exclusive but 
note that op+96 is not the same as op+64+32.) 

Esc[2;{attr};{row};{coI};{"string"}: 

- op+128 - {attr} omitted (use current screen’s current default value) 

- op+64 = {row};{coI} omitted (start at next position) 
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- op+32 = row value is added to current row; column is absolute 

(row value not incremented if cursor column position * 1) 

- op+96 * jrow};{coI| omitted but assumed to be current row+1;1, viz., 

|CRHLF} (row value not incremented if cursor column position = 1) 

- the current attribute value remains unchanged 


- Example: 


Esc 

Esc 

Esc 


2;116;1;1;"HELLO 
66;5;“THERE": 
226;"- 


N . 


- puts ‘HELLO * in the first five positions of the buffer as red on 
white; ‘THERE’ follows immediately in magenta on black; finally a 
line of dashes is displayed in the first position of the next line 
using the current default attribute (whatever it has been previously 
set to or the initial default, white on black) 


op=3 - Same as op=2 except that the default attribute byte for the current 
screen is reset if an attribute byte is specified. 

Esc[3;{attr};{row};{col};{“string"}: 

- the attribute byte for the current screen is reset if specified 

- Example: 

Esc[2;116;1;1;"HELLO 

Esc[67;5;"THERE": 

Esc[226;"-": 

- puts ‘HELLO * in the first five positions of the buffer as red on 
white; ‘THERE’ follows immediately in magenta on black with the 
default attribute getting reset accordingly; finally a line of dashes 
using the new current default, magenta on black, is displayed 
starting in the first position of the next line 


op»4 - Clear a window of the current screen buffer, i.e., moves spaces to the 
screen buffer window with the specified or current attribute byte. (Modifier «= 

128. ) 

Esc[4;jattr};{frow};jfcol \ ;{trow};jtcol }: 

- all arguments are optional 

- op+128 - {attr} omitted - use the current default attribute value 

- the default attribute byte is not updated 

- if any of the row or column values (either the from values or both the 
from and to values) are omitted then the values used will be the current 
settings set by the last op*1 command or by default; note that if {trow} 
is to be specified then {frow} and {fcol} must also be but JtcoI| needn’t 

- row/column coordinates define a ‘window’ to clear, not necessarily 
contiguous characters 

- if frow,fcoI - 4,21 and trow.tcol - 8,60 then only columns 21 through 
through 60 inclusive of rows 4 through 8 inclusive will be cleared in 
the currently active buffer 

- Example: 

Esc[4;112;20;1;25;80: 

- clears the current buffer from row 20, column 1 through row 25, 
coIumn 80 to white 

Esc[4;0;1;71;25;80: 

- clears columns 71 - 80 in all rows of the currently active buffer to 
b I ack 

Esc[4: 

( continued ) 
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- clears the currently defined window in the current screen buffer; 
the default attribute byte for the current screen is used to 
determine the background color 


op*5 - Same as op«4 except that the current attribute value for the current 
screen is reset to the specified value. 

Esc[5;{ottr};{frow};{fcol};{trow};{tcol}; 

- Example: 

Esc[5;112: 

— clears the currently defined buffer window and resets the current 
attribute byte to black characters on a white background 


op«6 - Clear (with spaces) from the position after the last located string 
(°P*2) in the current screen buffer to the end of that line. (Modifier « 128). 

Esc[6;{attr}: 

- op+128 means {a11r| omitted, i.e., use the current attribute value, viz., 
the value set by the last op*3 or op*5 command which specified an 
attribute byte 

- this is equivalent to specifying Esc[6: 

- the attribute value is not reset if specified 

- Example: 

Esc[2;23;10;1;: 

Esc[6;0: 

- this will put a white asterisk on a blue background in row 10, column 
1 of the buffer and clear the remainder of the line to black 


op«7 - Same as op«6 except that if an attribute byte is specified, the current 
default value will be reset. 

Esc[7;{at t r}: 

- the default attribute value for the current screen is reset if specified 

- Example: 

Esc[2;23;10;1;: 

Esc[7;112: 

- this will put a white asterisk on a blue background in row 10, column 
1 of the buffer and clear the remainder of the line to black; in 
addition, the default attribute byte for the current screen will be 
reset to white on black 

°P“8 - Set/reset the BIOS flag to control whether direct BIOS calls as well as 
DOS calls will be trapped. Also allows the suppression of keyboard redefinition 
(Modifier - 128). 

Esc[8;{flag}: 

- if {flag} is a 1 then direct BIOS calls will be trapped 

- if {flag} is omitted or anything else then BIOS calls will be ignored by 
the driver, i.e., the BIOS trap will be disabled 

- Example: 

Esc[8;1: 

- this will enable the driver to trap direct BIOS calls 

- issuing this command before going into BASIC will permit BASIC to 
directly stack commands; e.g.,to clear the screen at the end of a 
BASIC program one could specify 

CMOS - CHR$(34)+"CLS"+CHR$(34) 

PR I NT CHR$ (27 ) ♦•' [ " +CMD$+ “; 13. M ; 
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Esc[8: 

- this will disable the BIOS call trap 
Esc[136;jsuppress-count}: 

- if op+128 is specified then the flag value controls DOS keyboard 
redefinition: 

- a count other than 255 will be treated as a suppression count; no DOS 
keyboard redefinitions will be interpreted while this value is 
non-zero 

- a flag value of 255 will decrement the suppression count by 1 only if 
the latter is non-zero 

- if {flag} is zero or omitted DOS keyboard redefinition will be enabled 

- DOS keyboard redefinition is enabled by default 

- Example: 

Esc[136;2: 

- this will disable DOS keyboard redefinition so that programs which 
need the native key values will get them and not the redefinitions 

- the suppression count will be set to 2 in this case 

- NOTE: the {suppress-count} value used here should be one greater than 
that for the other commands (CLOCK, for example) since keyboard 
redefinition will be re-enabled as soon as the count goes to zero, 

NOT on the next ‘Esc[136* command 

Esc[136;255: 

- this will decrement the keyboard suppression count by 1; normally 
this command will be made part of the system prompt 

Esc[136: 

- this will re-enable DOS keyboard redefinitions 


op=9 - Set the number of screen rows, 25 or 43 (EGA). (Modifier = 32). 

Esc[9;{row-number}: 

- if {row-number} is omitted, 25 is assumed 

- use 43 row mode only with the EGA or equivalent and an enhanced color 
display or equivalent 


- op+32 means that the next {suppress-count} mode commands not specifying 
this modifier will be ignored. When this modifier is specified an extra 
argument, {suppress-count}, is expected before the attribute (if 
specified) which denotes a number between 0 and 255 indicating the number 
of standard (non op+32) commands to ignore. If a value of 255 is used 
all non op+32 commands will be ignored until the {suppress-count} is 
explicitly reset by a command with a 32 modifier. This option is useful 
for temporarily overriding the 43 line mode which may be defined within 
a PROMPT string. 

- for op+32 the command syntax is: 

Esc[41;{suppress-count};{row-number}: 

- if all arguments are omitted then {suppress-count} will be 
interpreted as zero, viz., permit subsequent non op+32 mode commands 

- Examples: 

Esc[41;2: 

- this will suppress the next two standard mode commands; note that 
the third normal mode command, normally from the PROMPT string, 
will reset the display to the desired mode as specified by the 
prompt string 


[continued) 
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Esc[41;255: 

- suppresses all subsequent standard mode commands until the 
Jsuppress-count} Is explicitly reset 

- the following Is a practical use for this feature; in It It is 
assumed that the PROMPT string contains a mode command. We wish to 
override the default mode for the duration of the dBASE program. 
The CU program is used to define a value for Alt-FI: 

CU AF1 "CU MODE 25 SUPPRESS 2(CD\DBASE}DBASE}" 

- this sets Alt-FI to ignore the next two mode commands from the 
next two system prompts resulting from the cd and dBASE 
commands so that the prompt string will not reset the default 
display mode; dBASE is then invoked and, upon the exit of 
dBASE, the prompt will reset the display to Its standard mode 


op-10 - Select the screen buffer. Four buffers are available but only one, 
buffer 0, is garanteed to be unaffected by program execution. Buffers 1-3* 
utilize the grophics memory area of the display adapter and thus will be 
destroyed by any application using the graphics mode. 

Esc[10;{buffer}: 

- {buffer$ should be o number from 0 to 3; If omitted then 0 is assumed 

- all subsequent screen operations will be directed to the chosen buffer 
until that value is reset; initially buffer 0 is the one used 

- Example: 


Esc 

Esc 

Esc 

Esc 


10 ; 1 : 

4;0;1;1;1;80: 

2;64;1;35;"A Title": 
1 ; 1 ; 1 ; 1 ; 80 ; 13 ; 1 : 


the next issuance of Esc[: will cause line one of buffer one to be 
displayed on line 13 of the screen; buffer 0 will be unaffected 


op-11 - Sets the CONDRV version and release values In IACA (0000:04F0) 
Esc[11: 

- no arguments are required 


op-12 - Adjust timer on/off, location, and attributes. (Modifiers = 128, 64, 32 
and 16). 

Esc[12;{attr};{row};{coI}: 

- all arguments are optional 

- clock (HH:MMxx where xx-am/pm) is displayed at specified location with 
specified attributes 

- if the {row} and/or {col} values are omitted then the clock will not be 
dispIayed 

- op+128 means {attr} omitted, i.e., use the current default value, viz., 
the attribute value of the last op=12 which specified an attribute 

- op+64 means that the colon will blink 

- op+32 means that the next {suppress-count} timer commands not specifying 
this modifier will be ignored. When this modifier is specified an extra 
argument, {suppress-count}, is expected before the attribute (if 
specified) which denotes a number between 0 and 255 indicating the number 
of standard (non op+32) commands to ignore. If a value of 255 is used 

all non op+32 commands will be ignored until the {suppress-count} is 
explicitly reset by a command with a 32 modifier. This option is useful 
for temporarily overriding standard clock attributes which may be defined 
within a PROMPT string. 
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- for op+32 the command syntax is: 

Esc[44;{suppress-count};{attr}; {row};{coI}: 

- note that if modifier=128 is also used then {attr} should be omitted 

and row and col values should immediately follow {suppress-count}; 

if all arguments are omitted then {suppress-count} will be 

interpreted as zero, viz., permit subsequent non op+32 timer commands 

- Examples: 

Esc[44;2;4;25;35: 

- this will suppress the next two standard timer commands and at the 
same time put the clock in red on black in about the middle of the 
bottom line of the screen. Note that the third normal timer command 
perhaps from the PROMPT string will reset the clock display to the 
standard values 

Esc[44;255: 

- suppresses all subsequent standard timer commands until the 
{suppress-count} is explicitly reset 

- the following is a practical use for this feature; in it it is 
assumed that the PROMPT string contains a timer command. We wish to 
override the timer for the duration of the 123 session. The CU 
program is used to define a value for Alt—F3: 

CU AF3 "CU CLOCK cb BLINK SUPPRESS 2 @ 25 35}CD\L0TUS}123}" 

- this sets Alt-F3 to move the clock display to line 25, column 
35 in black on cyan and to ignore the clock commands from the 
next two system prompts resulting from the cd and 123 commands 
so that the prompt string will not reset the default clock 
display; 123 is then invoked and, upon the exit of 123, the 
prompt will reset the clock to its standard mode 


- op+16 enables the clock if other arguments are specified or disables the 
clock if Esc[28: alone is specified 

- the clock MUST be enabled before any clock function will work, 
consequently the first clock call at least must contain this modifier 

- technically this causes the timer interrupt to be handled by the 
console driver and restored to its initial value by disable 


- Examples: 

Esc[12;112;1;74: 

- this will display a black clock on a white background in the upper 
right hand corner of an 80 column screen 

Esc[12: 

- this will turn off the clock 


13 - Set/clear alarm. (Modifier * 128). 

Esc[13;"hh:mmxx";{window}: 

- all arguments are optional 

- op+128 means just sound the alarm immediately; any other arguments will 
be ignored and no pending alarms will be reset 

- time ([h]h:mmxx where xx*am/pm) must be specified exactly as clock is 
with a leading space if the hour is only one-digit 

- {window} describes a screen buffer window in buffer 0 which will be 
displayed when the alarm goes off (0 - 3) 


( continued) 
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- any call made while an alarm Is ringing will reset the alarm 

- if no arguments are specified, any pending alarm is cleared as well 

- depressing both shift keys simultaneously will also reset the alarm: 
the system will beep twice to Indicate that the alarm has been reset 

Examp Ies: 

Esc[13;"12:15pm“: 

- when the timer contains o matching value of "12:15pm" a bell will be 
generated about every 30 seconds until the olarm is reset 

Esc[13;"12:15pm";1: 

this will additionally display window 1 when the alarm sounds 

Esc[13: 

7 this W,M dear any pending alarm ond will turn off the alarm If It 
is going off 


op -14 - Control 
screen toggle. 


display, location, ond attributes of caps and num 
(Modifiers - 128. 32, and 16). 


lock and print 


Esc[14;{a11 r|;{row};{col}: 


- all arguments are optional 

7 character lock display is displayed at the specified location with 
specified attributes 


if the |row} and/or {col} values are omitted then the locks will not 
be displayed 

op+128 means |a11r} omitted, i.e., use the current default value, viz . 
the attribute value of the last op-14 which specified an attribute 

op+32 means that the next {suppress-count} lock commands not specifying 
this modifier will be ignored. When this modifier is specified an extra 
argument.{suppress-count}, is expected before the attribute (if 
specified) which denotes a number between 0 and 255 indicating the number 
of standord (non op+32) commands to ignore. If a value of 255 is used 
all non op+32 commands will be ignored until the {suppress-count} is 
explicitly reset by a command with a 32 modifier. This option is useful 

JlthlnTpROMPT sUini d ' n9 St ° nd ° rd ,0ck tributes which moy be defined 


for op+32 the command syntax is: 

Esc[46;{suppress-count};{attrj;{row[;{colj: 

note that if modifier-128 is also used then {ottr| should be omitted 
and row and col values should immediately follow {suppress-count\; 
if all arguments are omitted then {suppress-count} will be 
interpreted as zero, viz., permit subsequent non op+32 timer commands 

- Examples: 


Esc[46;2;4;25;35: 

- this will suppress the next two standord lock display commands and 

s ? me tIme put * he lock d, splay in red on black in about the 
middle of the bottom line of the screen. Note that the third 
normal lock display command, perhaps from the PROMPT string, will 
reset the lock display to the standard values 

Esc[46;255: 


- suppresses all subsequent stondord lock display commands until the 
{suppress-count( is explicitly reset 

- the following is a practical use for this feature; in it it is 
assumed that the PROMPT string contains a lock display command. We 
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wish to override the lock disploy for the durotion of the 123 
session. The CU progrom is used to define a value for Alt-FI: 

CU AF3 "CU LOCK SUPPRESS 2}CD\L0TUS \ 123|" 

- this sets Alt-FI to turn off the lock disploy, ignore the lock 
display commands from the next two system prompts resulting 
from the cd and 123 commands, invoke 123 and then, upon the 
exit of 123, the prompt string will turn the lock display back 
on in standard format 

- op+16 enables the lock display if other arguments are specified or 
disables the lock display if Esc[30: alone is specified 

- the lock display MUST be enabled before any lock display function will 
work, consequently the first lock display call, at least, must contain 
this modifier 

- technically this causes the keyboard interrupt to be handled by the 
console driver and restored to its initial value by disable 

- Examples: 

Esc[14;112;1;67: 

- this will display the locks in black on a white background in the 
upper right hand corner of an 80 column screen in columns 67—73 

Esc[14: 

- this will turn off the lock display 


The following is a summary of the attribute byte values; for more details, see 
the IBM PC Technical Reference Manual: 


Monochrome case: 


Color case: 


0 * non-display 
1 * under Iine 
7 * normal 
112 * reverse video 


16 * (background color) + (foreground color) 


0 Black 

1 Blue 

2 Green 

3 Cyan 


Gray] 4 
Light blue] 5 
Light green] 6 
‘Light cyan] 7 


Red 

Magenta 

Brown 

White 


Light red] 
Light magenta] 
Ye I Iow] 

Bright white] 


For both the color and monochrome cases, add 128 to get a blinking field, and 
add 8 to get high intensity; high intensity color values are in brackets. [...]. 


To "stack" commands, i.e., make them available to the next DOS read request use 
the following display sequence: 

Esc[{command-strIng{. 

where {command-string \ may consist of a DOS command in quotes and/or ASCII 
decimal character values separated by semi-colons, e.g., *"CLS";13'. You may use 
the CU STACK command to effect this, e.g., 'CU STACK "CLS}"'. 

Stack commands may be issued from the system prompt to allow you to execute a 
batch file at every prompt. To do this the special stack commands, 'Esc[0.' and 
'Esc[1.' are used. Normally when Esc[0. or equivalently, Esc[., is "displayed" 
subsequent stack operations will be ignored. When Esc[l. is subsequently 
display then the next "display" of Esc[. will re-enable stacking. (Note that 
*Esc[1.• is NOT the same as 'Esc["1".'; the former represents a binary 1 
argument while the latter is the character 1). '$e[.' should be specified after 
the stack of the batch file in the prompt prompt string, e.g., 

'$e["BATFILE";13.$e.*. This will suppress subsequent stacking of the batch file 
command until specifically reset. Since the system prompt is generated for each 
displayed line of a batch file, and at least one must be displaced, e.g., ECHO 
OFF, this prevents the batch file from being reinvoked for every prompt caused 
by execution of the batch file itself. 'ECHO Esc[1.' should be the last 
statement in the batch file to permit stacking to be re-enabled for one prompt. 
'Esc' refers to the ESCAPE character, ASCII decimal value of 27. It may be 
entered Into a batch file using EDLIN via ' A V[* (Ctrl-V followed by a '['). 


(continued) 
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DOS key redefinitions may made via the console driver; see the DOS Technical 
Reference manual for details. If a console driver command as described above, or 
in the DOS Technical Reference manual, is defined as the new definition for a 
key, that command will be issued immediately upon depression of the key. No call 
to another program such as CU is needed. This is particularly useful for the 
immediated display of windows. For example, to display window 1 whenever the 
{Home} key is depressed pass the following string to the console driver: 

Esc[0;71;27;"[128;1:"p 


Note that this is equivalent to the more simple M CU HOME DISP WIND 1". 


The CONDRV commond of the CU program will append an *{Esc}[* (hexadecimal 27 and 
91 respectively) sequence to tbe beginning of the subsequent string argument. 

It may be used to issue the above commands explicitly instead of using the more 
limited CU syntax. For example, to associate a clear screen command with the 

{PgUp} key one could use "CU PGUP CLS}" or 

CU CONDRV *0;73;27;91;"2Jp # 

Note the need to place the *13.* inside of a quoted string to enable the 
carriage return to be evaluated when the key is pressed and not when it is 
associated with PGUP. 


MENU.BAT 

"Enhanced Console Driver," by Anthony Zackin, October 1986, page 183. 


echo off 

if .%1 »» .off goto OFF 
if .%i « .OFF goto OFF 
rem 


rem Set menu ON 
rem 


PROMPT 

' 31:40m$ ®[ 1 ; 1 H $p$e[ 1 4-;206; 1 ;67:$e[76; 14; 
1;74:$e[37;44m$e[25;1H$e[K$g L 

goto DONE 

:OFF 

prompt 

IJ 3 ® : £ 55 : $ e [ 9 : $ e [ 2 A$e [s$e [ 14-; 206; 1 ;8:$e[76; 14; 1; 1 :$e[1; 15H$e[K$e[31; 
40m$p$e[0;1;37;44m$e[K$e[u$e[B$g 1 L l • 

:D0NE 
c I s 


MENU1.BAT 

"Enhanced Console Driver," by Anthony Zackin, October 1986, page 183. 


echo off 

if .%1 =*= .off goto OFF 
if ,%l =* .OFF goto OFF 
rem 

rem Set menu ON 
rem 

PROMPT $e[13$;255:$«[10:$e[128;1:$e[1;31;40m$e[H$p $e[32m [$dl 
$e[76;14;1;74:$e[37;44m$e[25;1H$e[K$g 
goto DONE 
:OFF 

prompt $e[136;255:$e[2A$e[s$e[1;8H$e[K$e[76;14;1;1:$e[31;40m 
$p$e[0;1;37;44m$e[K$e[u$e[B$g$ 

:DONE 
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vENU2.BAT 

"Enhanced Console Driver," by Anthony Zackin, October 1986, page 183. 


echo off 

if .%1 ■■ .off goto OFF 
if .%1 ** .OFF goto OFF 
re m 

rem Set menu ON 

PROMPT $e[ 136 ;255:$e[10:$e[128:$e[128;1:$e[1;31;40m$e[1;1H$p 
$e[76;14;1;74:$e[37;44m$e[25;1H$e[K$g 
goto DONE 

prompt $e[136;255:$e[2A$e[s$e[1;8H$e[K$e[76; 14;1;1:$e[31;40m 
$p$e[0;1;37;44m$e[K$e[u$e[B$g$ 

:DONE 

Cl/sTACK "CU ALARM AT 12:00PM rV “ 


MENU25.BAT 

"Enhanced Console Driver," by Anthony Zackin, October 1986, page 183. 


echo off 

if .%1 ** .off goto OFF 
if ,xi «. .OFF goto OFF 
rem 

rem Set menu ON 

PROMPT $e[136;255:$e[9:$e[10:$e[128:$eM28;1:$e[1;31;40m$e[1;1H$p 
$e[14;206;1;67:$e[76;14;1;74:$e[37;44m$e[25;1H$e[K$g 
goto DONE 
:OFF 

$e['l36;255:$e[9:$e[2A$e[s$e[14;206;1;8:$e[76;14;1;1:$e[1;15H$e[K$e[31; 
40m$p$e[0;1;37;44m$e[K$e[u$e[8$g 
:DONE 
c I s 


MENU43.BAT 

"Enhanced Console Driver," by Anthony Zackin, October 1986, page 183. 


echo off 

if .XI ** .off goto OFF 
if .%i BS .OFF goto OFF 
rem 

rem Set menu ON 

PROMPT $e[ 136 ;255:$e[9;43:$e[10:$e[128:$e[128;1:$e[1;31;40m$e[1;1H$p 
$e[14;206;1;67:$e[76;14;1;74:$e[37;44m$e[43;1H$e[K$g 
goto DONE 
:OFF 

$e[136;255:$e[2A$e[s$e[14;206;1;8:$e[76;14;1;1:$e[1;15H$e[K$e[31;40m$p 

$e[0;1;37;44m$e[K$e[u$e[B$g 

:DONE 

C I 8 


{continued} 
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MENUMONO.BAT 

'Enhanced Console Driver," by Anthony Zackln, October 1986, page 183. 


echo off 

if .xi ==* .off goto OFF 
if .%1 — .OFF goto OFF 
rem 

rem Set menu ON 
rem 



:OFF 

prompt 

$e[136;255:$e[9:$e 
40m$p$e[0;1;37;44m 
: DONE 
c I s 




REAO.ME 

"Enhanced Console Driver," by Anthony Zackin, October 1986, page 183. 


Enhanced Console Driver 
Copyright (c) 1986 Anthony Zackin 

The current version of the program is 4.7 (all instances of 
replaced with the digits *47*). 


*xx* below should be 


The Enhanced Console Driver is an installable console driver providing 
additional capabilities to the disk operating system. It may be used with DOS 
versions 2 and above on systems with or without a hard disk. It is a complete 
rep acementfor the ANSI.SYS device driver supplied with DOS 2 and above It 
will work with either a monochrome or a color graphics adapter. Special support 
is also provided for the 43 line mode of the enhanced graphics adapter (EGA). 


Installation instructions: 

di8k th ® current| y active disk. If you already have a 
CONFIG.SYS file on your boot disk then issue a CD command to the subdirectory 
containing the file (for pre-DOS 3.0 systems this will be the root) Append the 
CONHGxx.SYS file from the distribution disk. This may be done with the^DOS * 
COPY command, e.g., COPY CONFIG.SYS+B:CONFIGxx.SYS assuming the distribution 
disk is in drive B. If you do not already have a CONFIG.SYS file then simply 
copy the CONFIGxx.SYS file and rename it to CONFIG.SYS e a P y 

COPY B:CONFIGxx.SYS CONFIG.SYS. ‘ 9 " 

... y h « CONFIGxx.SYS file contains the line DEVICE=CONDRVxx.SYS. This tells DOS 
that the console driver program. CONDRVxx.SYS. may be found in the root. If you 
are using DOS 3.0 or greoter you may place device drivers in any subdirectory 
If you wish to do this just modify the DEVICE- line in CONFIG.SYS and add a 
path name before CONDRVxx.SYS: DEVICE-[path]CONDRVxx.SYS, where [path] 
corresponds to the subdirectory path name where you have put the CONDRVxx.SYS 
file, e.g., DEVICE«\DOS\CONDRVxx.SYS if it is in your "DOS" subdirectory." 

Once you have added the DEVICE-CONDRVxx.SYS or equivalent entry to CONFIG.SYS 

Jrtr?l° U ^ill b ° 0t /jn r i! y ! t8m C ? USe the driver to b * loaded by DOS. Enter the 
}Ctrl{, jA11{, and f De1f keys simultaneously to "warm start" your machine. 


2) Copy the CU.EXE and MENU.BAT files from the distribution diskette to a 
subdirectory referenced by your default PATH definition; this will let them be 
frIm U !hf °l y ° Ur C .V r « n * «« bd •factory.. If you run all your programs 

root ^ yo2? boot / disk OV * ° PPy * yBt * m the " ju8t COpy the f,les to the 

The CU program (Console Utility) is used to issue commands to the console 
, v ? r .; , ese commands may define windows, set alarms, turn on/off the 

c ock/locks display, etc. Once CU has been copied you may issue the CU HELP 
command to find out how to get a listing of Its documentation. (Note that the CU 


170 BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 









October 


HELP facility expects that the console driver has been installed; if you view it 
before installation you may receive a few spurious characters at the end of each 
screen; if so, just ignore them.) 

MENU.BAT is a batch file which will set the system prompt. Since the menu, 
clock and caps-lock functions are all prompt driven you must set the prompt to 
control them. 


3) Copy the STDKEYS.CU and STDFKEYS.CU files from 
they may be accessible from your AUTOEXEC.BAT file 
commands to add key abbreviations (STDKEYS.CU) and 
(STDFKEYS.CU). They are meant as examples only and 
own needs. These names, by the way, are arbitrary; 
file name for these files; they will be referenced 
your AUTOEXEC.BAT file. Use the MENU.BAT or MENU2 


For a more complex menu setup try STDKEYS.1 and STDFKEYS.1. 
file with them. 


the distribution diskette so 
These files contain CU 
define a menu screen 
should be modified for your 
you may use any valid DOS 
by a 'CU READ* command in 
BAT file to set the prompt. 

Use the MENU1.BAT 


4} The following two lines should be added to your AUTOEXEC.BAT file. You may 
use the COPY command as described above, COPY AUTOEXEC.BAT+B:AUTOEXEC.BAT, or 
add them manually with a word processor or text editor: 


CU READ STDKEYS.CU,STDFKEYS.CU; CLOCK bY; LOCKS RY 
MENU ON 

The CU READ command will read the commands in the ‘STD...* files. Note that 
this is the convention that I use; you may choose to do it an other way. For 
example, you may decide to combine the two 'STD...* files into one and ca i 
MENUDEF. In that case you would add the line 


CU READ MENUDEF; CLOCK bY; LOCKS RY 


Instead. 

The CLOCK and LOCKS command are only needed if you wish a display of the 
current time and the Caps Lock/Num Lock/Print Screen status. They must be 
initialized via this CU call or else the prompt string commands to control them 
will be ignored. Any valid attribute value may be specified since the actual 
one used will be generated by the user’s prompt, set by the MENU.BAT file. 

Note that MENU ON must be the last command in the AUTOEXEC.BAT file since 
MENU is itself a batch file. If this is impossible then, of course, the MENU 
command may be issued manually at any time. 


5) Modify MENU.BAT if necessary to change the default colors; see the DOS 
technical reference manual for ANSI.SYS escape code sequences to do that. You 
may also change the location of the CLOCK and LOCKS status if you wish. Read the 
file CONDRV.DOC for full details of the extended escape sequences which control 
these functions. 

If you want to display more than one menu window you’ll have to modify the 
MENU.BAT file at least and you will probably want to modify the STDFKEYS.CU 
file as well. STDFKEYS.CU initially defines two windows but only window 0 is 
displayed by MENU.BAT. However, }Alt}0 is redefined to display windowl. The 
file MENU2.BAT on the distribution disk will set the prompt to display both 
windows (0 and 1). Up to 8 windows are supported. 

If you have an IBM Extended Graphics Adapter (EGA) and an Enhanced Color 
Display or equivalent and wish to use the 43 line mode when you are at the DOS 
prompt use MENU43.BAT to set the prompt for 43 line mode; use MENU25.BAT to 
switch to 25 line mode. 

The MENU.BAT files are set up so that if the parameter OFF is provided the 
prompt will be reset so that no windows will be displayed. You should modify 
the default MENU OFF prompt to suit your needs if the provided settings are not 
to your fancy. 


Note: 

The prompts specified In the MENU.BAT files may cause you to run out of 
environment space depending on how much of it you are using for your PATH, 

COMPSPEC, and any other environment variables. The default environment space 

(continued) 


BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER 1986 171 




October 


may be increased by patching the default paragraph allocation value of 10 

* n COMMANO.COM. You may use the DEBUG command to do this For 
DOS 2.0 replace xxx with ECF, for DOS 3.0 use F2C, for DOS 3.1 use Dll. 

>DEBUG \C0MMAND.COM 
-Exxx 0C 

This will give you an additional 32 bytes to work with; If you need more then 
specify a larger number than hexadecimal 0C (12 decimal). 

For DOS versions 3.2 and up you may use the following line In the CONFIG.SYS 
file to Increase the default environment space. Replace *nnn’ below with a 
number from 160 to 32768. It will be rounded up to the nearest paragraph 
boundary (multiple of 16 bytes): SHELL«\COMMAND.COM /P/E:nnn 

For example, 

SHELL»\COMMAND.COM /P/E:192 


Updates: 

4.3: 

A new feature in version 4.3 allows you to suppress the DOS keyboard 
redefinition during program execution (or at the DOS command prompt If you 
want). This lets programs which do their console I/O via DOS to use keys which 
you may hove redefined for your own purposes, e.g., to run the programs on your 
menu. Note that this has been implemented using a suppress count similar to the 
count used by the CLOCK, LOCKS, and MODE commands. It differs In one respect 
and that is that the suppress count value for keyboard redefinition must 
typically be one larger than the value needed by the other commands. After 
Installing the new CU program type ‘HELP KEYDEF* for more information. 


4.4: 

Fixes a problem that occurred with monochrome displays while resetting the alarm 
via the depression of both shift keys. 

4.7 

Fixes a problem that occurred when using the console driver with a RAM resident 
program, expanded memory, and 123 releose 2. Also fixed was a problem which 
sometimes would occur when both shift keys were depressed (to turn off the 
alarm); the system’s keyboard status bits would occasionally get scrambled 
making It look as If you were pressing a shift key when you weren't. 


Note that all code and documentation is copyrighted and may not be sold. If you 
[Ike It give It away, but please do not modify it. I can only vouch for the code 
in its current format; I use It every day on my system and on quite a few others 
in my office. I unfortunately cannot guarantee that it will work problem-free on 
all systems. The driver has been used with many software packages including 
123, Symphony, dBASE III, Framework, Microsoft Chart, GEM, DisplayWrite III 
WordStar, WordStar 2000, Storyboard, etc. without problems. The only program 
that I have found that it does not work with is Topview; however, if you are 
going to use Topview you don’t need this so who cares? Note that many of the 
programs listed above do not use DOS I/O to write to the console, they write 
directly to the screen memory or they use direct BIOS calls. Programs in the 
latter category may also issue the Enhanced Console Driver escape sequences if 
the BIOS trap option has been enabled prior to their execution. Read the CU HELP 
file for more information. 


If you have any questions or comments I wiI I try to respond, time permitting. 


Tony Zackin 
110-20 63rd Drive 
Forest Hills. NY 11375 
(718) 896-9385 
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STDFKEYS.1 

"Enhanced Console Driver," by Anthony Zackin, October 1986, page 183. 


AF1 "cu keydef suppress 3{cd \cal{cal jsr/W/U5{" 

AF2 "cd \caI{BACKUP jsr.d?? a:/a{" 

AF3 "cu mode 25 supp 2;keydef supp 3{CD\ROL{ROLODEX{" 

AF4 "CU CLOCK cb SUPPRESS 2;LOCKS SUPP 2jCD\123r2{123i" 

AF5 "cu mode 25 supp 2;locks supp 2;clock supp 2iCD\WP}WPP' 

AF6 "CU LOCKS SUPP 2 @ 25 67;CL0CK SUPP 2 @ 25 74{CD\XTALK}XTALK}" 

AF7 "CU LOCKS SUPP 2 @ 25 67;CL0CK SUPP 2 @ 25 74 CDNXTALKJXTALK cmoilmpl" 

AF8 "CU LOCKS SUPP 2 ® 25 67;CL0CK SUPP 2 @ 25 74}CD\XTALK}XTALK citimailj" 

AF9 "cd \{rem BACKUP *.* A:/A/S/D:mm-dd-yy} BACKUP *.* A:/A/S/D:" 

AF10 ’ rem CU ALARM AT hh:mm rY "message"! CU ALARM AT 

A1 CDXCALJ 
A2 C0\} 

A3 CD\ROL{ 

A4 CD\123R2| 

A5 C0\WP} 

A6 CDXXTALK} 

A7 CD\{ 

A8 *.* 

A9 CDM 
A0 CD\| 

A- "ERASE *.BAK{" 

A= DISPLAY WINDOW 0 

BUFFER 0 

CLEAR ww 1,1 thru 2.80 

* 1,1 wr " 1 23 4 5 678 90- 

*2.1 “XTALK WP 123R2 DBASE ROL \ \ *.* \ \ erase *.bak “ 

® 1.1 wr "1 23 4 56 8 

@ 2,1 "CAL \ ROL 123R2 WP XTALK *.* erase *.bak “ 

DEFINE WIND 01,1 THRU 2.80 AT 1,1 


@1,64 

bR 

"c vvvvvvvvvvvvvvv [" 

@2,64 

bR 

"7 




7" 

@3,64 

bR 

"7 




7" 

@ 4,64 

bR 

"7 




7" 

@5,64 

bR 

"7 




7" 

@6,64 

bR 

"7 




7" 

@7,64 

bR 

"7 




7" 

@8,64 

bR 

"7 




7" 

@9,64 

bR 

"7 




7" 

@10,64 

bR 

"7 




7" 

@11,64 

bR 

"7 




7" 

@12,64 

bR 

"7 




7" 

@13,64 

bR 

"7 




7" 

@14,64 

bR 

"7 




7" 

@15.64 

bR 

"Qvvvvvvvvvvvvi w) " 

@2,65 

mW 

"aF 1 

M 

cb 

ii 

Calendar " 

@ 3,65 

mW 

"aF2 

ii 

cb 

ii 

® backup " 

@4,65 

mW 

"aF3 

•i 

gw 

•i 

Rolodex " 

@5,65 

mW 

"aF4 

ii 

rW 

H 

Lotus 

@6,65 

mW 

"aF5 

n 

uW 

ii 

WordPerfct" 

@7,65 

mW 

"aF6 

n 

bG 

ii 

CrossTalk " 

@8,65 

mW 

H 

M 

bg 

•i 

Citimail " 

@9,65 

mW 

"aF7 

ii 

bG 

n 

oo MP ma i 1 " 

@10,65 

mW 

"oF8 

n 

bG 

ii 

* RW mail " 

@11,65 

mW 

"aF9 

ii 

wb 

ii 

BACKUP ■ wB 

@12,65 

mW 

n 

H 

wB 

ii 

after dote" 

@13,65 

mW 

"aF10" 

bY 

H 

Set alarm " 

@14,65 

wb 

"aL 

n 

bw 

ii 

List keys " 


DEFINE WIND 1 1.64 THRU 15.80 AT 1,64 


{continued) 
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STDKEYS.1 

"Enhanced Console Driver," by Anthony Zackln, October 1986, poge 183. 


AA "DIR A:/P{" 

A8 "DIR B:/P{" 

AC "COPY " 

AD "DAED " 

AE "ERASE " 

AF "FORMAT A:{" 

AG "FORMAT B: j" 

AH "~008~008~008~008~008~008~008~008~008~008" 

av npi e|N 

AL DISPLAY WIND 2 
AM "MORE<" 

AP "PRINT M 
AQ "DIR/P}" 

AR "RENAME " 

AS "SORT " 

AT "TYPE " 

AW "DIR/Wf" 

AX "DIR " 

AZ "CD " 


CLEAR ww 3,1 THRU 3,27 

©03,2 wb "{Alt}} Abbreviations" 

CLEAR BB 4,1 THRU 25.27 


<$NR, 2 

bY •; 

Alt 


:• bG 

©NR, 2 

bY •; 

Alt 


* bG 

©NR, 2 

bY * 

Alt 


* bG 

©NR, 2 

bY • 

Alt 


• bG 

©NR, 2 

bY • 

Alt 


* bG 

©NR, 2 

bY •; 

Alt 


* bG 

©NR, 2 

bY * 

Alt 


* bG 

©NR, 2 

bY •: 

Alt 


* bG 

©NR, 2 

bY • | 

Alt 


' bG 

©NR, 2 

bY 'j 

Alt 


’ bG 

©NR, 2 

bY V 

Alt 


* bG 

©NR, 2 

bY • i 

Alt 


’ bG 

©NR, 2 

bY •; 

Alt 


• bG 

©NR, 2 

bY •: 

Alt 


• bG 

©NR, 2 

bY ’« 

Alt 


* bG 

©NR, 2 

bY • i 

Alt 


* bG 

©NR, 2 

bY •: 

Alt 


>’ bG 

©NR, 2 

bY 

i A 11 


>’ bG 

©NR, 2 

bY ’ 

A11 


>’ bG 


’A* bW • 

DIR A:/P{Enter}} 

•B * bW • 

DIR B:/P{Enter}} 

’C’ bW * 

COPY • 

*D' bW • 

DAED * 

E* bW • 

ERASE • 

F* bW * 

FORMAT A:{Enter} 

G' bW * 

FORMAT B:{Enter} 

H* bW • 

od backspace 10 « 

K* bW • 

CLS{Enter}} • 

L* bW • 

oo lists this! oo* 

M* bW * 

MORE< 1 

P* bW • 

PRINT • 

Q* bW * 

DIR/P{Enter}} • 

R* bW • 

RENAME * 

S’ bW • 

SORT • 

T* bW * 

TYPE * 

W* bW • 

DIR/W{Enter}} • 

X* bW • 

DIR • 

Z # bW • 

CD ’ 


DEFINE WIND 2 AS 3,1 THRU 21,27 AT 3,25 


STDKEYS.CU 

"Enhanced Console Driver," by Anthony Zackln, October 1986, page 183. 


AA "DIR A:/P|" 

AB "DIR B:/P}" 

AC "COPY " 

AD "DVED " 

AE "ERASE " 

AF "FORMAT A:}" 

AH "~008~008~008~008~008~008~008~008~008~008" 
AK "CLS}" 

AM "MORE<" 

AP "PRINT " 

AQ "DIR/P}" 

AR "RENAME " 

AS "SORT " 

AT "TYPE " 

AW "DIR/W}" 

AX "DIR " 

AZ "CD " 
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STDFKEYS.CU 

"Enhanced Console Driver," by Anthony Zackln, October 1986, page 183. 


AF1 "CU LOCKS SUPP 2 @ 25 67;CLOCK SUPP 2 ® 25 74{CD\XTALK}XTALK}" 

AF2 "CU LOCKS SUPP 1;CLOCK SUPP 1}BASICA \UTIL\HPSETUP}" 

AF3 "CU CLOCK cb BLINK SUPPRESS 2 @ 25 35;LOCKS SUPP 2}CD\LOTUS}123}" 

AF4 "CU CLOCK SUPP 2;LOCKS SUPP 2}CD\123R2}123}" 

*F5 "CU MODE 25 SUPP 2}CD\DBASE}DBASE}" <- use with MENU43.BAT 

AF5 CDNDBASE}DBASE} 

AF6 cd\ws}ws| 

AF7 "cd\ws}ws TO.DO}" 

AF8 "cd\wsjws REPORT}" 

AF9 "CU MODE 25 SUPP 2; KEYDEF SUPP 3}CD\ROL}ROLODEX TONY}" 

AF10 AF10 


A1 CD\} 

A2 CD\123R2} 

A3 CDXXTALK 
A4 CD\DBASE} 

A5 CD\UTIL} 

A6 CDXUSER| 

A7 CDXDOS} 

A8 *.* 

A9 CD\} 

A0 DISP WIND 1 
A- "ERASE *.BAK}" 


@ 1,64 br " ivvvvvvvvvvvvvvvi." 


@NR,64 

br 

"7 




7" 


®NR,64 

br 

"7 




7" 


®NR,64 

br 

"7 




7 " 


®NR.64 

br 

"7 




7 " 


@NR,64 

br 

"7 




7 " 


®NR,64 

br 

"7 




7 " 


®NR,64 

br 

"7 




7 " 


@NR,64 

br 

"7 




7 " 


@NR,64 

br 

"7 




7 " 


®NR,64 

br 

"Qvvvvvvvvvvvvvvv ')" 


® 2,65 

mW 

M aF1 

H 

bY 

H 

Crossta1k 

n 

@NR,65 

mW 

M aF 2 

ii 

wB 

ii 

HP Setup 

ii 

®NR.65 

mW 

"aF3 

H 

rw 

ii 

123 


@NR,65 

mW 

M aF4 

H 

rW 

ii 

123 REL 2 


®NR.65 

mW 

M aF5 

n 

bW 

n 

dBASE 


@NR,65 

mW 

M aF6 

ii 

cW 

ii 

WordStar 


®NR,65 

mW 

M aF7 

ii 

cW 

ii 

ao To do 


@NR.65 

mW 

M aF8 

" 

cW 

ii 

a> Report 


@NR,65 

mW 

"aF9 

it 

uW 

H 

Ro1odex 

n 


DEFINE WIND 0 AS 1,64 THRU 11,80 AT 1,64 
CLEAR ww 1.1 THRU 2.63 

® 1,05 wu "1"; @ 1,14 wu "2"; @ 1,23 wu "3"; ® 1,32 wu "4"; @ 1,41 wu "5" 

@ 1,50 wu "6"; @ 1,59 wu "7" 

® 2 01 wU "CD"; ® 2,05 wu "\”; @ 2,12 wu "\123R2"; ® 2,21 wu "\XTALK" 

® 2,30 wu "\DBASE"; @ 2,39 wu "\UTIL"; ® 2,48 wu "\USER"; @ 2,57 wu "\DOS" 

DEFINE WIND 1 AS 1,1 THRU 2,63 AT 1,1 
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IBM Extra Edition 


LISTING1.DOC 

"Writing Assembly Language Interrupt Routines," by 

William J. Claff. Inside the IBM PCs, Extra Edition, page 249. 


;=======I NT ERR UPT VECTOR STRUCTURE 

VECTOR STRUC 
REGIP DW ? 

REGCS DW ? 

VECTOR ENDS 

i ====s=== KEYBOARD SHIFT FLAG RECORD 
KBFLAGS RECORD INS:1.CAPS:1,NUM:1,SCROLL:1, 
ALT:1.CTL:1,LEFT:1.RIGHT:1 


;■■■■■■■CODE SEGMENT 
CODE SEGMENT 

;*******EXECUTION starts with this piece 

ASSUME CS:CODE,DS:CODE,ES:CODE,SS:CODE 
; PROGRAM SEGMENT PREFIX 
INCLUDE PSP.INC 

; LABEL FOR END STATEMENT 

IP LABEL NEAR 

JMP SHORT START 

;*******INTERRUPT INTERCEPT PIECE 

ASSUME CS:CODE,DS:NOTHING,ES:NOTHING 
ASSUME SS:NOTHING 

ORG05 VECTOR <> ;ORIGINAL INT 

; 005H VECTOR 

.-INTERCEPT ROUTINE 

INT05 PROC FAR 

PUSH AX 

MOV AH.002H ;GET KEYBOARD 

; FLAGS FROM BIOS 


INT 016H 

; TEST FOR RIGHT SHIFT KEY 

TEST AL.MASK RIGHT 

POP AX 
JNZ INT05X 

; NOT DOWN, DO ORIGINAL INT 005H 
JMP ORG05 

INT05X LABEL NEAR 

IRET 

INT05 ENDP 

;**♦***♦INITIALIZATION PIECE 

ASSUME CS:CODE,DS:CODE,ES:CODE,SS:CODE 

START LABEL NEAR 

;-GET INT 5 VECTOR AND SAVE IN ORG05 

PUSH ES 

MOV AH.035H 

MOV AL,005H 

INT 021H 

ASSUME ES:NOTHING 

MOV ORG05.REGIP.BX 

MOV ORG05.REGCS.ES 

POP ES 

ASSUME ES:CODE 

;-SET INT 5 VECTOR TO INT05 

MOV AH.025H 
MOV AL.005H 
MOV DX,OFFSET INT05 
INT 021H 

;-FREE MEMORY ALLOCATED TO THE ENVIRONMENT 

PUSH ES 

MOV AH.049H 

MOV ES,ENVIRONMENT 

ASSUME ES:NOTHING 


{continued) 
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INT 021H 

POP ES 

ASSUME ES:CODE 

; -TERMINATE PROTECTING MEMORY BELOW START 

MOV DX,OFFSET START 
INT 027H 

CODE ENDS 

END IP ;NOTE IP FOR EXE2BIN 


LISTING2.DOC 

"Writing Assembly Language Interrupt Routines," by 

William J. Claff. Inside the IBM PCs, Extra Edition, page 249. 


^PROGRAM SEGMENT PREFIX 



INT 

TOP_OF_MEMORY 

DW 


DB 


DB 

TERMINATE 

VECTOR 

CTRL.BREAK 

VECTOR 

CRITICAL_ERROR 

VECTOR 

DW 

DB 

ENVIRONMENT 

DW 


DW 


DB 

DOS_CALL 

PROC 


INT 


RET 

DOS_CALL 

ENDP 

DB 

FORMATTED_AREA_1 

DB 

F ORMATTED_AREA_2 

DB 


DB 

UNFORMATTEDJ.ENGTH 

DB 

UNFORMATTED_AREA 

DB 


020H 

? 

;INT 020H 

? 

;IOCTL 

5 DUP(?) 

<> 

<> 

<> 

;DOS_JMP 

? 

;USED BY DOS 

20 DUP(?) 

? 

;USED BY DOS 

7 DUP(?) 

;USED BY DOS 

20 DUP(?) 

FAR 

;UNUSED ? 

021H 

;INT 021H 
;RET 

9 DUP(?) 

16 DUP(?) 

16 DUP(?) 

;UNUSED ? 

4 DUP(?) 

? 

127 DUP(?) 

;UNUSED 


LISTING3.DOC 

"Writing Assembly Language Interrupt Routines," by 

William J. Claff. Inside the IBM PCs, Extra Edition, page 249. 


; =======VECTOR STRUCTURE 

VECTOR STRUC 

REGIP DW ? 

REGCS DW ? 

VECTOR ENDS 

;====*=== DATA SEGMENT 

DATA SEGMENT PUBLIC * DATA* 

CLKDIV DW ? ;<- USER PROVIDED DIVISOR 

PUBLIC CLKDIV 

; ACTUAL DIVISOR ... 

CLKDIVH DW ? ;...(HIGH WORD) 

CLKDIVL DW ? ;...(LOW WORD) 

CLKMOD DW ? ; DIVISOR MODULUS 

; USER-PROVIDED NEAR PROCEDURE 
CLKRTN DW ? 

PUBLIC CLKRTN 

INT08 VECTOR <> ;INTERCEPTED INT 008H VECTOR 

DATA ENDS 

;====*—STACK SEGMENT 

STACK SEGMENT STACK ‘STACK* 

STACK ENDS 

;=======CODE SEGMENT 

CODE SEGMENT PUBLIC ’CODE* 

ASSUME CS:CODE,DS:DATA,ES:DATA,SS:STACK 
EXTRN SEGCODE:WORD ;<- CODE SEGMENT 

EXTRN SEGDATA:WORD ;<- DATA SEGMENT 
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; ****#**CLKRATE CLOCK RATE SETTING ROUTINE 
CLKRATE PROC NEAR 
;-LOAO COUNTER 0 OF THE 8259 


PUSH 

AX 

MOV 

AL,00110110B 

OUT 

043H.AL 

POP 

AX 

OUT 

040H.AL 

XCHG 

AH, AL 

OUT 

040H.AL 

XCHG 

AH, AL 

RET 


CLKRATE ENDP 


;*******CLKPRO 

CLOCK PROLOGUE 

CLKPRO PROC 

NEAR 

PUBLIC 

CLKPRO 

PUSH 

AX 

PUSH 

DX 

.-INITIALIZE CLK VARIABLES 

XOR 

AX, AX 

CALL 

CLKRATE 

MOV 

CLKDIV,AX 

MOV 

CLKDIVH,1 

MOV 

CLKDIVL,AX 

MOV 

CLKMOD,AX 

MOV 

CLKRTN,OFFSET CLKNUL 

;-SAVE CURRENT INTERRUPT VECTOR 

PUSH 

ES 

MOV 

AH,035H 

MOV 

AL,008H 

INT 

021H 

ASSUME 

ES:NOTHING 

MOV 

INT08.REGIP,BX 

MOV 

INT08.REGCS.ES 

POP 

ES 

ASSUME 

ES:DATA 

;-INSTALL 

INTERRUPT INTERCEPT VECTOR 

PUSH 

DS 

MOV 

AH.025H 

MOV 

AL.008H 

MOV 

DX,OFFSET CLKINT 

MOV 

DS.SEGCODE 

ASSUME 

DSrCODE 

INT 

021H 

POP 

DS 

ASSUME 

DS:DATA 

POP 

DX 

POP 

AX 

RET 


CLKPRO ENDP 


;*******CLKEPI 

CLOCK EPILOGUE 

CLKEPI PROC 

NEAR 

PUBLIC 

CLKEPI 

PUSH 

AX 

PUSH 

DX 

;-RESET CLOCK DIVISOR TO 65536 

XOR 

AX. AX 

CALL 

CLKRATE 

.-reset INTERRUPT VECTOR 

PUSH 

DS 

MOV 

AH.025H 

MOV 

AL.008H 

LDS 

DX.INT08 

ASSUME 

DS:NOTHING 

INT 

021H 

POP 

DS 

ASSUME 

DS:DATA 

POP 

DX 

POP 

AX 

RET 


CLKEPI ENDP 


•♦♦♦♦♦♦♦interrupt ROUTINES 

ASSUME 

CS:CODE,DS:NOTHING,ES:NOTHING 

ASSUME 

SS:NOTHING 

; ♦♦♦♦♦♦♦CLKINT 

CLOCK INTERRUPT INTERCEPT ROUTINE 


[continued) 
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CLKINT 

PROC 

FAR 


PUSH 

AX 


PUSH 

DS 


PUSH 

ES 

t 

■ESTABLISH ADDRESSABILITY 


MOV 

DS.SEGDATA 


ASSUME 

DS:DATA 


MOV 

ES,SEGDATA 


ASSUME 

ESrDATA 

• 

-DO USER 

ROUTINE. 


CALL 

CLKRTN 

; —- 

-CHECK FOR ROLL-OVER OF 65536 CYCLES 


MOV 

AX.CLKDIVL 


ADD 

CLKMOD.AX 


MOV 

AX.CLKDIVH 


ADC 

AX, 0 


JNZ 

CLKINT8 

; -- 

-NOT TIME YET, SKIP ORIGINAL INTERRUPT 


MOV 

AL,00100000B 


OUT 

020H.AL 


JMP 

CLKINT7 


-DO THE 

ORIGINAL INTERRUPT. 

CLKINT8 

LABEL 

NEAR 


PUSHF 



CALL 

INT08 

CLKINT7 

LABEL 

NEAR 

* 

-CHANGE 

DIVISOR IF SO REQUESTED 


MOV 

AX.CLKDIV 


CMP 

AX,CLKDIVL 


JE 

CLKINTX 


CALL 

CLKRATE 


MOV 

CLKDIVL,AX 


CMP 

AX, 1 


MOV 

CLKDIVH,0 


ADC 

CLKDIVH,0 

CLKINTX 

LABEL 

NEAR 


POP 

ES 


ASSUME 

ES:NOTHING 


POP 

DS 


ASSUME 

DS:NOTHING 


POP 

AX 


IRET 


CLKINT 

ENDP 


; *******CLKNUL 

INITIAL USER PROVIDED ROUTINE 

CLKNUL 

PROC 

NEAR 


RET 


CLKNUL 

ENDP 


CODE 

ENDS 



END 



LISTING4.DOC 

"Writing Assembly Language Interrupt Routines," by 

William J. Claff. Inside the IBM PCs, Extra Edition, page 249. 


;=======VECTOR STRUCTURE 

VECTOR STRUC 
REGIP DW ? 

REGCS DW ? 

VECTOR ENDS 
; =======PSP SEGMENT 

PSP SEGMENT AT 0FFFFH 
; PROGRAM SEGMENT PREFIX 
INCLUDE PSP.INC 


PSP 

ENDS 

-RATA CPf 

-UFKJT 


DATA 

■Un 1 M OCA 

SEGMENT 

jML IN 1 

PUBLIC 

•DATA* 


EXTRN 

CLKDIV: 

WORD 


EXTRN 

CLKRTN: 

WORD 

COL 

DB 

0 

;COLUMN 

DIR 

DB 

1 

:DIRECTION 

LEFT 

DB 

9 

;NUMBER LEFT 

COLS 

DB 

? 

;LAST COLUMN (0 RELATIVE) 
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SPEED DW 1000000000000000B ;SPEED MASK 

DEEPS DW 000000000000000IB ;BACKWARDS! 

DATA ENDS 

STACK SEGMENT 

STACK SEGMENT STACK ’STACK’ 

DW 128 DUP(?) 

STACK ENDS 

..CODE SEGMENT 

CODE SEGMENT PUBLIC ’CODE’ 

ASSUME CS:CODE.DS:PSP,ES:PSP,SS:STACK 
EXTRN CLKEPI:NEAR 

EXTRN CLKPROiNEAR 


DOSCALL 

VECTOR 

<> 

;WILL POINT TO 




; PSP:DOS_CALL 

SEGCODE 

DW 

CODE 

;CODE SEGMENT 


PUBLIC 

SEGCODE 


SEGDATA 

DW 

DATA 

;DATA SEGMENT 


PUBLIC 

SEGDATA 


IP 

LABEL 

NEAR 

;EXECUTION STARTS HERE 

» 

-SETUP 

DOSCALL VECTOR 


MOV 

DOSCALL, 

.REGIP,OFFSET DOS_CALL 


MOV 

DOSCALL, 

.REGCS,DS 

» 

-SETUP 

DS AND ES 

REGISTERS 


MOV ES,SEGDATA 

ASSUME ES:DATA 

MOV DS,SEGDATA 

ASSUME DS:DATA 

■DETERMINE LAST COLUMN 
MOV AH,00FH 

INT 010H 

DEC AH 

MOV COLS,AH 

MOV LEFT,AH 

-INITIALIZE CLK MODULE 
CALL CLKPRO 

-SET CLOCK ROUTINE 



MOV 

CLKRTN,OFFSET 

INT08 


JMP 

SHORT SETRATE 


MAI NX 

LABEL 

NEAR 



CALL 

CLKEPI ;DEINSTALL CLK MODULE 

» 

-RETURN 

TO DOS 



MOV 

AH,000H 



CALL 

DOSCALL 


| ——— 

-SET CLK 

RATE 


SETRATE 

LABEL 

NEAR 



MOV 

AX,SPEED 



OR 

AX,DEEPS 



AND 

AX,1111111100000000B 


SHL 

AX, 1 



MOV 

CLKDIV,AX 


* 

-WAIT FOR KEYSTROKE 


KEY 

LABEL 

NEAR 



MOV 

AH, 0 



INT 

016H 



CMP 

AL.01BH 



JE 

MAI NX 

;EXIT ON ESCAPE 


ROR 

SPEED,1 

;OTHERWISE, 


ROL 

DEEPS,1 

; CHANGE SPEED 


JMP 

SETRATE 



;*******interrupt routine 

ASSUME CS:CODE,DS:DATA,ES:DATA,SS:NOTHING 
; NEAR PROC CALLED BY INT08 


INT08 PROC 

NEAR 

PUSH 

AX 

PUSH 

BX 

PUSH 

CX 

PUSH 

DX 

PUSH 

BP 

PUSH 

SI 

PUSH 

DI 

;-POSITION CURSOR 

MOV 

AH,002H 

MOV 

BH, 0 
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SHOWX 


INT08 

CODE 


MOV DH,0 

MOV DL.COL 

INT 010H 

■DERIVE CHARACTER FROM TIME OF DAY 


MOV 

AH, 0 

INT 

01 AH 

MOV 

AL.DL 

AND 

AL.00111111B 

ADD 

AL, * * • 

■PUT CHARACTER ON THE SCREEN 

MOV 

AH.00AH 

MOV 

BH, 0 

MOV 

CX,1 

INT 

010H 

■UPDATE 

COLUMN 

MOV 

AL.DIR 

ADD 

COL,AL 

DEC 

LEFT 

JNZ 

SHOWX 

NEG 

DIR 

MOV 

AL.COLS 

MOV 

LEFT,AL 

LABEL 

NEAR 

POP 

DI 

POP 

SI 

POP 

BP 

POP 

DX 

POP 

CX 

POP 

BX 

POP 

AX 

RET 


ENDP 


ENDS 


END 

IP 


MCDFIG5.ASM 

"Using Assembly Routines in MS-FORTRAN Programs," 

by Mark Dahmke. Inside the IBM PCs. Extra Edition, page 217. 


; SETFRAME: Sets the environment upon entry to a subroutine. 

SETFRAME MACRO 

PUSH BP ;SAVE FRAMEPOINTER ON STACK 

MOV BP.SP 

ENDM 

• 

; POPRET: Restores the BP register and returns to the 

; calling FORTRAN routine after cleaning up the 

; stack. 

POPRET MACRO NPARMS ;RETURN FROM SUBR. NPARMS=NUMBER OF PA=vS 

POP BP 

RET NPARMS*4 

ENDM 

• 

; GETPARM: returns a pointer to a parameter in the call list. 

> 

; Operands: X ■ the number of the desired parameter 

; MAX = the maximum number of parameters in 

; the call list. 

i 

; Result: The ES:BX register pair points to the parameter. 

GETPARM MACRO X.MAX -.PARAMETER NUMBER (IE. 1,2,3) 

LES BX,DWORD PTR SS:[BP+(MAX-X)*4+6] 

ENDM 
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MCDFIG7.ASM 

"Using Assembly Routines In MS-FORTRAN Programs," 

by Mark Dahmke. Inside the IBM PCs, Extra Edition, page 217. 


PAGE 66,132 

; Utility subroutines for use with MS-FORTRAN 

; by Mark Dahmke 

; May, 1986 

PUBLIC SRCHF, SRCHN, CHDIR, GETDIR, GETDFS 

SUBTTL ’MACROS’ 

PAGE 

5- MACROS - 

DOS MACRO 

INT 21H ;REQUEST DOS SERVICE 

ENDM 


SETFRAME: Sets the environment upon entry to a subroutine. 

;SAVE FRAMEPOINTER ON STACK 


SETFRAME MACRO 

PUSH BP 

MOV BP,SP 

ENDM 


POPRET: Restores the BP register and returns to the 

calling FORTRAN routine after cleaning up the 
stack. 


POPRET MACRO 
POP 
RET 
ENDM 


NPARMS 

BP 

NPARMS*4 


;RETURN FROM SUBR. NPARMS=NUMBER OF PARMS 


GETPARM: returns a pointer to a parameter in the call list. 

Operands: X « the number of the desired parameter 
MAX ■ the maximum number of parameters in 
the call list. 

Result: The ES:BX register pair points to the parameter. 

GETPARM MACRO X,MAX ;PARAMETER NUMBER (IE, 1.2,3) 

LES BX,DWORD PTR SS:[BP+(MAX-X)*4+6] 


» 

ENDM 



. 

» 

SUBTTL 

PAGE 

’DATA SEGMENT’ 


DATA 

SEGMENT 

PUBLIC ’DATA’ 


SDMA 

DB 

128 DUP(0) 

;DMA BUFFER FOR SRCHF AND 

FCB 

DB 

0 



DB 

8 DUP(0) 

FILE NAME (1-8) 


DB 

0.0.0 

FILE TYPE (9-11) 


DW 

0 

CURRENT BLOCK (12-13) 


DW 

0 

LOGICAL RECORD SIZE (14-15) 


DW 

0.0 

FILE SIZE (16-19) 


DW 

0 

DATE (20-21) 


DW 

0.0.0.0.0 

RESERVED (22-31) 


DB 

0 

CURRENT RELATIVE RECORD 


DW 

0.0 

RELATIVE RECORD NUMBER 
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DB 0 

OB 0 


IDRIVE DW 0 

STRING DW 0 

STRING_SEG DW 0 

DATA ENDS 
DGROUP GROUP DATA 

SUBTTL ‘CODE SEGMENT * 

PAGE 

CODE SEGMENT ‘CODE* 

ASSUME CS:CODE, DS:DGROUP, SS:DGROUP 


SEARCH FOR FIRST DIRECTORY ENTRY 


PARM LIST: CALL SRCHF(IDRV,FSPEC,RFNAME) 


INPUT: IDRV, FSPEC — 0-CURRENT, 1-A, 2-B, FSPEC- ????????.??? 
OUTPUT: RFNAME — FILENAME.TYP 


SRCHF 


PROC 

FAR 

;SEARCH FOR FIRST DIR ENTRY 

SETFRAME 


GETPARM 

1.3 

;GET DRIVE CODE ADDR 

MOV 

AX,ES:[BX] 

;GET VALUE 

MOV 

IDRIVE,AX 


MOV 

FCB,AL 

;SET UP FCB 

GETPARM 

2,3 

;GET FILESPEC 

MOV 

STRING,BX 


MOV 

STRING.SEG 

i.ES ;SAVE PTR AND SEG 

MOV 

DI.OFFSET 

DGROUP:FCB+1 

PUSH 

DS 

;SAVE DS 

PUSH 

DS 


POP 

ES 

;SET UP DEST 

MOV 

SI,STRING 


MOV 

DS,STRING. 

.SEG 

MOV 

CX,11 


REP 

MOVSB 

;COPY FILESPEC 11 CHARS 

POP 

DS 

;RESTORE DS 

MOV 

DX,OFFSET 

DGROUP:SDMA 

MOV 

AH,1AH 


DOS 


;SET DMA ADDRESS 

MOV 

DX.OFFSET 

DGROUP:FCB 

MOV 

DOS 

AH.11H 

;SEARCH-FIRST BDOS COMMAND 

CMP 

AL.0FFH 


JZ 

NO.FILES 

;IF NO FILES. SKIP OUT. 

GETPARM 

3,3 

;GET RETURN FILENAME ADDR IN ES:BX 

MOV 

DI, BX 

;SET UP ES:DI POINTER FOR MOVE 

MOV 

SI,OFFSET 

DGROUP:SDMA+1 ;POINT TO FILE NAME 

PUSH 

DS 


POP 

ES 

;SET UP DEST SEG 

MOV 

CX,11 

;MOVE 11 BYTES 

REP 

MOVSB 


JMP 

S_DONE 



NO_FILES: ;IF NO FILES ARE PRESENT, 

GETPARM 3,3 

MOV BYTE PTR ES:[BX],*?* ;PUT A ? IN FIRST CHAR 

;OF OUTPUT FILE NAME 

S.DONE: POPRET 3 
SRCHF ENDP 
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SEARCH FOR NEXT DIRECTORY ENTRY 

PARM LIST: CALL SRCHN(IDRV,FSPEC,RFNAME) 

INPUT: IDRV, FSPEC -- 0-CURRENT, 1-A, 2-B, 
OUTPUT: RFNAME — FILENAME.TYP 

SRCHN 


FSPEC- ????????.??? 


PROC 

FAR 

;SEARCH FOR NEXT DIR ENTRY 

SETFRAME 


GETPARM 

1.3 

;GET DRIVE CODE ADDR 

MOV 

AX,ES:[BX] 

;GET VALUE 

MOV 

IDRIVE,AX 


MOV 

FCB.AL 

;SET UP FCB 

GETPARM 

2,3 

;GET FILESPEC 

MOV 

STRING.BX 


MOV 

STRING_SEG 

,ES ;SAVE PTR AND SEG 

PUSH 

DS 

-.SAVE SEG 

PUSH 

DS 


POP 

ES 


MOV 

DI,OFFSET 

DGROUP:FCB+1 

MOV 

SI,STRING 


MOV 

DS,STRING_ 

.SEG 

MOV 

CX,11 


REP 

MOVSB 

;COPY FILESPEC 11 CHARS 

POP 

DS 


MOV 

DX,OFFSET 

DGROUP:SDMA 

MOV 

AH,1AH 


DOS 


;SET DMA ADDRESS 

MOV 

DX,OFFSET 

DGROUP:FCB 

MOV 

AH.12H 

;SEARCH-NEXT BDOS COMMAND 

DOS 



CMP 

AL.0FFH 


JZ 

NNO.FILES 

;IF NO FILES, SKIP OUT. 

GETPARM 

3.3 

;GET RETURN FILENAME ADDR 

MOV 

DI.BX 

;SET UP ES:DI POINTER FOR 

MOV 

SI.OFFSET 

DGROUP:SDMA+1 ;POINT TO FILE NAME 

MOV 

CX,11 

;MOVE 11 BYTES 

REP 

MOVSB 


JMP 

N_DONE 



NNO_FILES: ;IF NO FILES ARE PRESENT. 

GETPARM 3,3 

MOV BYTE PTR ES:[8X],*?' ;PUT A ? IN FIRST CHAR OF OUTPUT FILE NAME 

;OUTPUT FILE NAME 

N.DONE: POPRET 3 
SRCHN ENDP 


GETDIR: RETURN ASCII STRING CONTAINING CURRENT DIRECTORY PATH 


; CALL GETDIR(PATH,IDRIVE,ICODE) 

; PATH - CHARACTER*64 (RETURNED PATH NAME) 

; ICODE * INTEGER (RETURN CODE) 

; IDRIVE- INTEGER (DRIVE, 0-DEFAULT, 1-A, 2-B) 

• NOTE: PATH IS RETURNED WITH NO STARTING BACKSLASH 

; AND WITHOUT THE DRIVE LETTER AND COLON. 

; THE PATH STRING IS TERMINATED WITH A ZERO BYTE. 

GETDIR PROC FAR ;GET PATH NAME ON IDRIVE 

SETFRAME 

GETPARM 1,3 
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MOV 

STRING,BX 

;SAVE PTR TO OUTPUT STRING AREA 

MOV 

string.seg.es 

;AND SEG 

GETPARM 

2,3 

;GET DRIVE CODE ADDR 

MOV 

AX,ES:[BX] 

;GET VALUE 

MOV 

IDRIVE,AX 

;AND SAVE IT 

PUSH 

DS 


MOV 

SI,STRING 

;SET UP PATH STRING POINTER 

MOV 

DX,IDRIVE 

;GET DRIVE NUMBER 

MOV 

AX.STRING.SEG 


MOV 

DS, AX 


MOV 

AH.47H 

;GET DIRECTORY NAME 

DOS 



GETPARM 

3.3 


MOV 

AH, 0 

;CLEAR OUT AH 

MOV 

ES:[BX],AX 

;STORE IT 

POP 

DS 


POPRET 

3 


GETDIR ENDP 




CHDIR: SET DIRECTORY PATH TO STRING FOUND IN PATH. 


» 

; CALL 

CHDIR(PATH,ICODE) 


» 

» 

PATH 

= CHARACTER*64 

(INPUT PATH NAME) 

• 

ICODE 

= INTEGER 

(RETURN CODE) 

8 

» 

NOTE: 

PATH MUST CONTAIN 

THE PATH NAME, TERMINATED BY 

» 


A ZERO BYTE. THE 

DRIVE LETTER AND COLON AND 

, 


BACKSLASH MAY BE - 

AT THE START OF THE STRING. 

CHDIR 

PROC 

FAR 

;SET PATH NAME 

» 

SETFRAME 


1 \ 

GETPARM 1,2 



MOV 

STRING.BX 

;SAVE PTR TO INPUT STRING AREA 


MOV 

STRING.SEG.ES 

;AND SEG 

» 

PUSH 

DS 

;SAVE DS 


PUSH 

ES 



POP 

DS 



MOV 

DX.BX 

;SET UP PATH STRING POINTER 

* 

MOV 

AH.3BH 

;SET DIRECTORY PATH 


DOS 



* 

GETPARM 2,2 

;POINT TO ICODE 


MOV 

AH, 0 

;CLEAR OUT AH 


MOV 

ES:[BX],AX 

;STORE IT 

* 

POP 

DS 

•.RESTORE DS 


POPRET 2 


CHDIR 

ENDP 




GETDFS: GET DISK FREE SPACE IN BYTES. 


; CALL GETDFS(IDRIVE,IBYTES,ISECT,ICLUST) 

! IDRIVE- INTEGER*2 (DRIVE NUMBER) 

; IBYTES- INTEGER*2 (NUMBER OF BYTES /SECTOR) 

; ISECT = INTEGER*2 (NUMBER OF SECTORS / CLUSTER) 

; ICLUST- INTEGER*2 (NUMBER OF CLUSTERS REMAINING) 

; IF ISECT - FFFFh THEN ERROR: INVALID DRIVE CODE 

GETDFS PROC FAR ;GET SPACE REMAINING 
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SETFRAME 
GETPARM 1,4 

MOV DX,ES:[BX] ;GET DRIVE NUMBER 

MOV AH,36H ;SET DIRECTORY PATH 

DOS 

THIS FUNCTION RETURNS: AX=FFFF IF ERROR, 

BX - NUMBER OF CLUSTERS AVAILABLE 
CX = NUMBER OF BYTES PER SECTOR 
AX = NUMBER OF SECTORS PER CLUSTER 

THEREFORE, IBYTES » AX * BX * CX 


PUSH 

BX 

; PUSH 

ICLUST 

GETPARM 

2,4 



MOV 

ES:[BX],CX 

;SAVE 

IBYTES 

GETPARM 

3,4 

;SAVE 

ISECT 

MOV 

ES:[BX],AX 



GETPARM 

4,4 



POP 

AX 



MOV 

ES:[BX],AX 

;SAVE 

ICLUST 


POPRET 4 
GETDFS ENDP 

CODE ENDS 
END 


MCDFIG8.FOR 

"Using Assembly Routines in MS-FORTRAN Programs," 

by Mark Dahmke. Inside the IBM PCs, Extra Edition, page 217. 


$STORAGE: 2 

C 

C 

C Demonstration MS-FORTRAN program using assembler 

C subroutine calls. 

C 

C by Mark Dahmke 

C May, 1986 

C 

C This program displays the current directory path, 

C then allows you to enter a new directory name. 

C Next, it displays all filenames in the directory, 

C and also shows the amount of free disk space remaining. 

C 

C 

CHARACTERS PATH 
CHARACTER*11 FSPEC 
CHARACTER*11 FNAME 
CHARACTER*1 ZERO 
INTEGER IDRIVE,ICODE 
INTEGER*4 ISPACE 
C 
C 

DATA PATH /’ */ 

DATA FSPEC /•???????????•/ 

DATA FNAME /' '/ 

C 

ZERO - CHAR(0) 

C 

C GET PATH NAME: 

C 

C 

IDRIVE - 0 
C 

CALL GETDIR(PATH,IDRIVE,ICODE) 
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c 

IF (ICODE .NE. 0) THEN 

WRITE(*,*) * ERROR RETURN: \ ICODE 
ENDIF 
C 

C - CLEAR OUT THE ZERO BYTE BEFORE WRITING TO CONSOLE... 

C 

DO 4 I - 1, 65 

IF (PATH(I:I) .EQ. ZERO) PATH(I:I) - * * 

4 CONTINUE 
C 

WRITE(*,*) • Current Directory is: \PATH 
C 
C 

C - CHANGE DIRECTORY 

C 

PATH - ’ 1 

5 WRITE(*,*) * Enter name of directory: * 

READ(*,6) PATH 

6 FORMAT(A65) 

C 

C - SCAN PATH NAME TO FIND LAST CHARACTER. 

C INSERT A ZERO BYTE AT THE END OF THE STRING. 

C 

I * 64 

10 IF (PATH(I:I) .NE. * *) GO TO 20 

I - I - 1 

IF (I .EQ. 0) GO TO 5 
GO TO 10 

20 1*1 + 1 

PATH(I:I) - ZERO 
C 
C 
C 

CALL CHDIR(PATH,ICODE) 

C 

IF (ICODE .NE. 0) THEN 

WRITE(*,*) * INVALID DIRECTORY NAME OR FORMAT 
ENDIF 
C 

C - DISPLAY FILE NAMES IN THE CURRENT DIRECTORY. 

C 

C 

CALL SRCHF(IDRIVE,FSPEC,FNAME) 

C 

IF (FNAME(1:1) .EQ. *?*) THEN 
WRITE(*, *) ' NO FILES* 

GO TO 100 
ENDIF 
C 

WRITE(*,40) FNAME(1:8),FNAME(9:11) 

40 FORMAT(IX,A8,•.•,A3) 

C 

C - CONTINUE TO READ FILE NAMES 

C 

C 

50 CALL SRCHN(IDRIVE,FSPEC,FNAME) 

C 

IF (FNAME(1:1) .EQ. *?*) GO TO 100 
C 

WRITE(*,40) FNAME(1:8),FNAME(9:11) 

GO TO 50 
C 
C 

C - GET DISK FREE SPACE 

C 

C 

100 CALL GETDFS(IDRIVE,IBYTES,ISECT,ICLUST) 

C 

ISPACE * IBYTES * ISECT * ICLUST 
C 

WRITE(*,60) IDRIVE,IBYTES,ISECT,ICLUST,ISPACE 
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60 FORMAT(* Drive 9 ,12,* has ’,16,* bytes per sector*,/, 

& IX,16,* sectors per cluster, and *,I8, * free clusters.*,//, 
& * Total free space in bytes « *,112) 

C 

C 

STOP 

END 


EMSDISK.ASM 

"Lotus/Intel/Microsoft Expanded Memory," by Ray Duncan. 
Inside the IBM PCs, Extra Edition, page 168. 


\foot4 

\ctr\- \%page\ - 

\right 

605057 

\left 

\lm0 

\rm80 

\hy 

\ssa 

\ssb 

\bf 

\un 

name emsdisk 

page 55,132 

title EMSDISK for Expanded Memory 

; EMSDISK for Lotus/Intel/Microsoft Expanded Memory 

; Copyright (C) 1986 Ray Duncan 
; version 1.0 May 1986 
» 

; This program may be freely reproduced and modified for 
; non-commercial (personal) use. It may not be resold or 
; incorporated into products for resale without written 
; permission from the author. 

; To convert EMSDISK.ASM into the executable EMSDISK.BIN: 

; OMASM EMSDISK; 

; OLINK EMSDISK; 

; OEXE2BIN EMSDISK.EXE EMSDISK.BIN 

; C>DEL EMSDISK.EXE 

» 

; To link the EMSDISK into the MS-DOS operating system, 

; copy the EMSDISK.BIN file to your boot disk and add the line: 

; DEVICE-EMSDISK.BIN nnnK 

; Into the CONFIG.SYS file on your boot disk (where nnnK is the 
; desired EMSDISK size in Kbytes) AFTER the line that loads 
; the Expanded Memory Manager (EMM.SYS for Intel Above Board). 


code segment public ’CODE* 

assume cs:code.ds:code.es:code 



org 

0 


cc2_max 

equ 

12 

» 

cc3_max 

equ 

16 

• 

cr 

equ 

0dh 

9 

If 

equ 

0ah 

9 

blank 

equ 

020h 

9 

eom 

equ 


9 

emm_lnt 

equ 

67h 

9 


max driver command code for DOS 2 
max driver command code for DOS 3 

ASCII carriage return 
ASCII Iine feed 
ASCII space code 
end of message signal 

Software Interrupt for communication 
with Expanded Memory Manager 


( continued ) 
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page_size equ 
sec_size equ 

dlr_size equ 


16384 

512 

256 


bytes per logical EMS page 

bytes per logical sector, should 
be some multiple of 512 <* 16384. 

entries In root directory 


; logical sectors per EMS page 
sec_per_page equ page_size/sec_size 

page 

; MS-DOS Request Header structure definition 

request struc ; request header template structure 

beginning of “Static" portion 
length of request header 
unit number for this request 
request header’s command code 
driver’s return status word 
bit 15 = Error 

bits 10-14 = Reserved 
bit 9 ■ Busy 

bit 8 * Done 

. bits 0-7 = Error code If bit 15=1 

8 dup (?) ; reserved area 

end of "Static" portion, the remaince' 
is struc. for Read and Write commoncs 
media descriptor byte 
memory address for transfer 
byte/sector count value 
starting sector value 
end of request header template 


r1ength 

db 

? 

un 11 

db 

? 

command 

db 

? 

status 

dw 

? 

reserve 

db 

8 

med i a 

db 

? 

address 

dd 

? 

count 

dw 

? 

sector 

dw 

? 

request 

ends 



page 



Device Driver header 


header 


dd 

dw 


-1 

0 



dw 

strat ; 


dw 

int r ; 


db 

1 ; 


db 

7 dup (0) 

rh_ptr 

dd 

? ; 

save_sp 

dw 

0 ; 

save_ss 

dw 

0 

avail_pages 

dw 

0 

total_pages 

dw 

0 ; 

req_pages 

dw 

0 

owned_pages 

dw 

0 ; 

page_frame 

dw 

0 ; 

emm_hand1e 

dw 

0 

dos_ver 

db 

0 ; 

max_cmd 

dw 

0 ; 

xfer_sec 

dw 

0 ; 

xfer_cnt 

dw 

0 ; 

xfer_req 

dw 

0 ; 

xfer_addr 

dd 

0 ; 


bit 

bit 

bit 

bit 


link to next device driver in chain 
device attribute word 
bit 15 »1 for character devices 
=0 for block devices 

if driver can handle IOCT- 
If block device & non-IBv fo'nct 
reserved 

if OPEN/CLOSE/RM supporter DCS 2 
reserved 
if CLOCK device 
if NUL device 
if Standard Output 
if Standard Input 
device "Strategy" entry point 
device "Interrupt" entry point 
number of units, this device 
; reserved area (block dev. drivers 


14 -1 
13 -1 
12 

11 =1 
bits 4-10 
bit 3 =1 

bit 2 -1 

bit 1 =1 

bit 0 =1 


logical EMS pages available 
total logical EMS pages in syste- 
EMSDISK requested size in EMS pages 
logical EMS pages owned by EMSDISK 
segment address of page frame 
EMSDISK EMM handle (process id) 

DOS major version no. 

maximum command code, this DOS ve r s 

current sector for transfer 
sectors successfully transferred 
number of sectors requested 
working address for transfer 
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bpb_array 
cmd_line 

stk 


dw bpb ; array of pointers to BPB for each unit 

; copy of CONFIG.SYS line for driver 
db 80 dup (0) 

even ; force word alignment 

dw 128 dup (0) 

equ $ ; local stack for use by driver 


page 



boot_rec 

equ 

$ 


jmp 

$ 


nop 



db 

'EMRAMDSK 


bpb 

dw 

sec_size 

sec_c1 us 

db 

0 


dw 

1 


db 

1 


dw 

dir_size 

tot_sec 

dw 

0 


db 

0f 8h 

sec_fat 

dw 

0 

boot_rec_len 

equ 

$-boot_rec 


; phony JMP at start of 
; boot sector, this field 
; must be 3 bytes. 

; OEM identity field 

; BIOS Parameter Block (BPB). 

; "sectors per cluster", "total 
; sectors" k "sectors per FAT" 

; are updated by "setup" procedure 
; 0 bytes per sector 
; 2 sectors per cluster 
; 3 reserved sectors 
; 5 number of FATs 
; 6 root directory entries 
; 8 total sectors 
; 0AH media descriptor 
; 0BH sectors per FAT 

; length to copy to 
; EMSDISK logical sector 0 


page 

EMSDISK Device Driver "Strategy Routine" 

Each time a request is made for the logical unit assigned 
to the EMSDISK, MS-DOS first calls the "Strategy Routine", 
then immediately calls the "Interrupt Routine". 

The Strategy Routine is passed the address of the 
Request header in ES:BX, which it saves in a local 
variable and then returns to MS-DOS. 


strat proc 

mov 

mov 


far 


; save address of Request header 
word ptr cs:[rh_ptr],bx 
word ptr cs:[rh_ptr+2],es 


ret 


back to MS-DOS 


strat endp 


page 


EMSDISK Device Driver "Interrupt Routine" 

This entry point is called by MS-DOS immediately after 
the call to the "Strategy Routine", which saved the long 
address of the Request header in the local variable "rh_ptr". 

The "Interrupt Routine" uses the Command Code passed in 
the Request header to transfer to the appropriate device 
handling routine. Each Command Code subroutine returns 
with AX«status. 


intr 

proc 

far 



push 

ax 

; save general registers 


push 

bx 



( continued) 
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intr1: 


1 n t r 2: 


I n t r 3: 


intr4: 


push 

cx 


push 

dx 


push 

ds 


push 

es 


push 

di 


push 

si 


push 

bp 


mov 

ax,cs 

; make local data addressable 

mov 

ds ,ax 


mov 

save_ss, ss 

; save DOS's stock pointers 

mov 

save_sp,sp 

mov 

ss, ox 

; set SS:SP to point to 

mov 

sp,offset stk 

; (larger) local stack 

les 

di,[rh_ptr] 

; let ES:DI » Request header 



; get BX ■ command Code 

mov 

b1,es:[di.command] 

xor 

bh,bh 


cmp 

bx,max_cmd 

; make sure it’s legal 

jle 

Intr 1 

; jump, function code is ok 

mov 

ax,8003h 

; set Error bit and "Unknown command" code 

Jmp 

Intr3 


or 

bx, bx 

; is it Init call? (function 0) 

Jz 

i nt r2 

; yes, skip save of context 

mov 

ah,47h 

; save EMM page map for 

mov 

dx,emm_hand1e 

; the interrupted process 

Int 

67h 

or 

ah, ah 

; jump if EMM error while 

jnz 

intr9 

; saving page mapping context 

shl 

bx, 1 

; form index to dispatch table and 
; branch to command code routine 

ca 1 1 

word ptr [bx+di 

spatch] 



; should return AX * status 

1 es 

di,[rh_ptr] 

; restore ES:DI * addr of Request header 

or 

ax,0100h 

es:[di.status], 

; merge Done bit into status, and 
; store into Request header 

mov 

ax 



; Was this initialization call? 

mov 

b1,es:[di.command] 

or 

bl , b 1 


jz 

i nt r4 

; yes, skip restore of context 

mov 

ah,48h 

; restore EMM page map 

mov 

dx,emmjiand1e 

; for interrupted process 

1 nt 

67h 

or 

ah ,ah 

; jump if EMM error while 

jnz 

i nt r9 

; restoring page mapping 



; central exit point from 



; driver’s "INTR" routine 

mov 

ss,save.ss 

; restore DOS’s stack 

mov 

sp,save_sp 


pop 

bp 

; restore general registers 

pop 

s i 


pop 

di 


pop 

es 


pop 

ds 


pop 

dx 


pop 

cx 


pop 

bx 


pop 

ax 


ret 


; back to MS-DOS 
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; come here if disastrous EMM error 
; encountered to set "General Failure" 
; error code and return to MS-DOS 

; ES:DI * addr of Request header 

; Set Error bit, Done bit, and 
; Error Code 12 (0CH) 
mov es:[di.status],810ch 

jmp intr4 

intr endp 


; MS-DOS Command Codes dispatch table. The "Interrupt" routine uses 
; this table and the Command Code supplied in the Request Header to 
; transfer to the appropriate driver subroutine. Table entries for 
; command codes not supported by this driver point to a dummy routine 
; that only sets the "done" status and exits. 

dispatch: 

dw 
dw 
dw 
dw 
dw 
dw 
dw 
dw 
dw 
dw 
dw 
dw 
dw 
dw 
dw 
dw 
dw 

page 


Command Code subroutines called by Interrupt Routine 

These routines are called with ES:DI ■ Request Header. 

They should return AX = 0 if function was completed 
successfully, or AX * 8000H + Error code if function failed. 


media_chk proc near ; command code 1 * Media Check 

; return "not changed" code 
mov byte ptr es:[dt+14],1 

xor ax,ax ; set "done" status 

ret 

media_chk endp 


init 

media_chk 

buiId_bpb 

dummy 

read 

dummy 

dummy 

dummy 

wr i te 

wr i te 

dummy 

dummy 

dummy 

dummy 

dummy 

dummy 

dummy 


0 = Initialize driver 

1 = media check on block device 

2 * build BIOS parameter block 

3 = I/O control read 

4 = read from device 

5 = non-destructive read 

6 = return current input status 

7 = flush device input buffers 

8 = write to device 

9 * write with verify 

10 « return current output status 

11 * flush output buffers 

12 ■ I/O control write 

13 ** device open (DOS 3.X) 

14 = device close (DOS 3.X) 

15 = removeable media (DOS 3.X) 

16 * output until busy (DOS 3.X) 


i n t r 9: 

les di,[rh_ptr] 


buiId_bpb proc near 


command code 2 * Build BPB 


; return BPB address in request header 
mov word ptr es:[di+18l.offset bpb 
mov word ptr es:[d1+20J,cs 

xor ax,ax ; set "done" status 

ret 


buiId_bpb endp 


read proc near 


command code 4 ■ Read 
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cal 1 

1n1t_xfer 

readl: 

mov 

ax,xfer_cnt 


cmp 

ax,xfer_req 


Je 

read2 


mov 

ax,xfer_sec 


cal 1 

map_sec 


Jc 

read4 


1 es 

di,xfer_addr 


mov 

8 i, ax 


mov 

ds,page_frame 


mov 

old 

cx,sec_size 


rep 

movsb 


push 

cs 


pop 

ds 


inc 

xfer_sec 


add 

word ptr xfer_< 


inc 

xfer_cnt 


Jmp 

readl 

read2: 


xor 

X 

o 

X 

o 

read3: 

1 es 

di.[rh_ptr] 


mov 

bx,xfer_cnt 


mov 

ret 

es : [di.count],t 

read4: 


mov 

ax,800bh 


jmp 

read3 

read 

endp 



set up local variables 

done with all sectors yet? 

Jump if transfer completed 
get next sector number 
and map it 

jump if mapping error 
ES:DI ■ requestor's buffer 
DS:SI - EMSDISK address 

transfer logical sector from 
EMSDISK to requestor 

restore local addressing 

advance sector number 
advance transfer address 
,sec_size 

count sectors transferred 


all sectors successfully 
transferred, return ok status 

get address of Request header 
and poke in actual transfer count 
(in case error aborted transfer 
early) 

come here if mapping error deteced 
return read fault error code 


wr i te 

proc 

near 


cal 1 

1nit_xfer 

wr1 tel: 

mov 

ax,xfer_cnt 


cmp 

ax,xfer_req 


j« 

wr ite2 


mov 

ax,xfer_sec 


ca 1 1 

map_sec 


jc 

wr i te4 


mov 

di ,ax 


mov 

es,page_frame 


1 ds 

si,xfer_addr 


mov 

old 

cx,sec_size 


rep movsb 


push 

cs 


pop 

ds 


i nc 

xfer_sec 


add 

word ptr xfer. 


i nc 

xfer_cnt 


jmp 

wr itel 

write2: 


xor 

ax ,ax 

write3: 


1 es 

di,[rh_ptr] 


mov 

bx,xfer_cnt 


mov 

ret 

es:[di.count], 

write4: 


mov 

ax,800ah 


jmp 

write3 

write 

endp 



; command code 8 ■ write 
; command code 9 * write/verify 

; set up local variables 

; done with all sectors yet? 

; jump if transfer completed 
; get next sector number 
; and map it 

; jump if mapping error detected 

; ES:DI = EMSDISK address 

; DS:SI * requestor’s buffer 

; transfer logical sector from 
; requestor to EMSDISK 

; restore local addressing 

; advance sector number 
; advance transfer address 
.addr , sec_s i ze 

; count sectors transferred 


; all sectors successfully 
; transferred, return ok status 


; get address of Request header 
; and poke in actual transfer count 
bx ; (in case error aborted transfer 
; early) 

; error detected 
; return write fault error code 
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dummy proc near 

xor ax,ax 

ret 

dummy endp 
page 


this command code routine is 
called for functions that are 
not supported or are applicable 
to character devices only. 

return success flag for all 


Map into memory a logical "disk" sector from the EMS 
pages allocated to the EMSDISK. 


Cal led with: 

AX 

* logical sector number 

Returns: 

CY 

* clear if no error 


AX 

* offset within EMS page 


; AX,CX,DX destroyed 

J CY = set if EMM mapping error 

; AX.CX.DX destroyed 

map_sec proc near 


mov 

dx ,0 

divide sector no. by sectors 

mov 

cx,sec_per_page 

per page, to get EMS page number 

di v 

cx 

now AX*EMS page,DX=rel. sector 

push 

dx 

save remainder 

mov 

bx,ax 

BX <- EMS page number 

mov 

ax,4400h 

map function, phys. page=0 

mov 

dx,emm_hand1e 

process ID for EMSDISK 

int 

67h 


or 

ah, ah 

; if EMM error, jump to return flag 

jnz 

map_sec1 


pop 

ax 

get remainder (relative sector) 

mov 

cx,sec_size 

remainder*sec_size to get offset 

mu 1 

cx 

into EMS logical page 

c 1 c 


return CY«clear for no error 

ret 


back to cal 1er 

1: 


come here if EMM mapping error 

add 

sp,2 

clear stack 

stc 


return CY«set for error 

ret 




map_sec endp 


Set up to perform Read or Write subfunction by copying 
requestor’s buffer address, starting sector, and sector 
count out of Request header into local variables. 


init_xfer proc near ; call ES:DI*request header 

; extracts addr, start, count 
; to working variables 

push es ; save Request header addr 

push di 

; initialize working variables 
; for transfer 
mov ax,es:[d1.sector] 

mov xfer_sec,ax ; starting sector number 

mov ax,es:[dl.count] 

mov xfer_req,ax ; sectors requested 

Ies di,es:[di.address] 

; requestor’s buffer offset 
mov word ptr xfer_addr,dl 

; requestor's buffer segment 
mov word ptr xfer_oddr+2,es 


[continued) 
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; Init sectors transferred count 
; restore Request header addr 


mov 

xfer_cnt,0 

pop 

di 

pop 

ret 

es 


init_xfer endp 
page 


; The Initialization code for the driver Is called only 
; once when the driver is loaded. For a block device, it 
; must return the number of units, address of an array of 
; pointers to BPBs for each unit, and the address of the 
; first free memory above the driver in the Request Header. 

; Only MS-DOS services 01-0CH and 30H can be called by the 
; Initialization function. 

; "Init" returns Its own address to the DOS as the start of 
; free memory after the driver, so that the memory occupied 
; occupied by "init" and Its subroutines will be reclaimed. 

init proc near ; command code 0 * Initialize Driver 

; on entry ES:DI ■ request header 


les dl,es:[dl+18] ; get addr of CONFIG.SYS line 

; and copy It to local buffer 

mov si,offset cmd_line 

; CX « max line length to copy 

; get next character of line 
; found Carriage Return yet? 

; yes, end of line 
; no, copy this character 
; bump string pointers 

; loop unless 80 characters copied 

; get DOS version 

; and major version no. for later 

; set maximum legal command code 
mov max_cmd,cc2_max ; assume DOS 2.X 

cmp a 1,2 

Je In112 ; jump if DOS 2 

mov max_cmd,cc3_max ; was DOS 3+, set higher value 


mov 

i n110: mov 
cmp 
Je 
mov 
inc 
Inc 
loop 

Initl: mov 
int 
mov 


cx ,80 

al,es:[di] 
a I ,cr 
initl 
[si],al 
di 
si 

I n i 10 

ah,30h 
21 h 

dos_ver,al 


Init2: 


xor 

ax, ax 

mov 

es, ax 

mov 

bx,emm_int*4 

mov 

es,es:[bx+2] 

mov 

di ,10 

mov 

si .offset emm. 

mov 

cld 

cx,8 

repz 

cmpsb 

jz 

In i t3 

mov 

dx,offset msg 

jmp 

Init_err 


check If EMM driver present 
if EMM is present, address in 
vector points to EMM driver, 
now ES:0000 would point to EMM header 
let ES:DI = addr of device name field 
let DS:SI = addr of EMM driver name 

length of device name field 

compare EMM name to driver header, 
jump if strings matched, 
if strings didn't match, 
driver is absent, exit. 


init3: mov 
int 
or 

j* 

mov 

jmp 


ah,40h 
67h 
ah ,ah 
i n i 14 

dx,offset msg2 
init_err 


EMM driver module is present, 
test EM Manager status. 

jump, driver is OK 

EMM is non-functional, orint 

error message and exit 


init4: mov 
int 
or 

jz 

init 45: mov 
jmp 


ah,46h 
67h 
ah ,ah 
i n 115 

dx,offset msg3 
init_err 


; check EM Manager version 


; jump, got version ok 
; print EMM error message 
; and exit, discarding driver 
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init5: 


ini 16 : 


init7: 


i n i 18 


i n i 19 


in i t 


cmp 

a 1,030h 

; make sure at least ver. 3.0 

jae 

i n i 16 

; jump if EMM version adequate 

mov 

dx,offset msg6 


jmp 

init_err 

; EMM version too early, exit 

mov 

ah,41h 

; get page frame segment 

int 

67h 


or 

ah, ah 


jnz 

Init45 

; jump if failed to get frame 

mov 

page-frame,bx 

; save segment of page frame 

mov 

ah,42h 

; get number of available pages 

int 

67h 


or 

ah, ah 


jnz 

init45 

; jump if error on get pages 

mov 

tota1 ..pages,dx 

; save total EMM pages 

mov 

avail_pages,bx 

; save available EMM pages 

or 

bx.bx 


Jnz 

i n i 17 

; proceed if some pages available 

mov 

dx,offset msg4 


jmp 

init_err 

; no EMS pages left, exit 

cal 1 

get_kb 

; convert desired size of EMSDISK 

mov 

ah,43h 

; try and allocate EMM pages 

mov 

bx,owned_pages 


int 

67h 

; if allocation is successful 

or 

ah ,ah 


jz 

i n i 18 

; jump, allocation was successful 

mov 

dx,offset msg5 

; if allocation failed, print 

jmp 

init_err 

; error message and exit 

mov 

emm_hand1e,dx 

; save EMM handle for this driver 

ca 1 1 

setup 

; set up Bios Parameter Block 

cal 1 

format 

; format the EMSDISK 

jnc 

ini t9 

; jump If no error during format 

mov 

dx,offset msg7 

; formatting error, exit 

jmp 

inlt_err 


ca 1 1 

signon 

; format and display driver ident 

1 68 

di,cs:[rh_ptr] 

; restore ES:DI*Request header 



; return first usable memory addr 



; ("break address") above driver 

mov 

word ptr es:[di 

.address],offset init 

mov 

word ptr es:[dl 

.address+2],cs 



; return EMSDISK logical units = 

mov 

byte ptr es:[di+13]»1 



; return address of BPB array 

mov 

word ptr es:Tdi+18],offset bpb_array 

mov 

word ptr es:[di+20],cs 

xor 

a 

X 

Q 

X 

; return success status 

ret 



ir r: 


; EMM initialization failed, 



; print error message and 



; discard EMSDISK driver. 

push 

dx 

; save specific error message 

mov 

dx,offset ermsg ; print error heading 

mov 

ah, 9 


int 

21 h 


pop 

dx 

; now print error description 

mov 

ah ,9 


int 

21 h 


1 66 

di,cs:[rh_ptr] 

; restore ES:DI*Request header 


[continued] 
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; discord this driver... 


mov 

word ptr es:[di 

.address],0 

mov 

word ptr es:[d! 

.address+2],cs 

; set number of logical unlts=0 

mov 

byte ptr es:[dl+13],0 

xor 

O 

X 

o 

X 

; return status 

ret 

In1t endp 

setup proc 

near 

; calculate BPB fields depending 
; on number of sectors in EMSDISK 

mov 

ax,owned_pages 

; find total sectors in EMSDISK, 

mov 

cx,sec_per_page 

; update BIOS parameter block 

mu 1 

cx 


mov 

tot_sec,ax 

; store into (word ptr bpb+8) 

; determine number of sectors 
; per cluster (allocation unit). 

; must have tot. clusters <4087 
; so can use 12-bit FAT fields. 

mov 

cx,2 

; start with 2 sectors/cluster 

setupl: mov 

ax,tot_sec 

; try this cluster size... 

mov 

dx,0 

; divide total sectors by 

di v 

cx 

; sectors per cluster. 

cmp 

ax,4086 

; resulting clusters < 4087? 

jna 

setup2 

; yes, use it 

sh 1 

cx, 1 

; sec/c1uster*2, try again 

jmp 

setupl 

setup2: mov 

sec_c1 us,c1 

; update sectors per cluster 
; in Bios Parameter Block 

; now AX * total clusters in disk 

mov 

dx,ax 

; clusters*!.5 ■ FAT bytes needed 

add 

ax, ax 

; (* 2) 

add 

ax,dx 

; C* 3) 

shr 

ax, 1 

; (/ 2) 

mov 

dx, 0 

; FAT bytes needed / bytes/sector 

mov 

cx,sec_size 

; * number of FAT sectors needed 

d i v 

cx 

or 

dx,dx 

; any remainder? 

Jz 

setup3 

; no,jump 

Inc 

ax 

; round up to next sector 

setup3: mov 

sec_fat,ax 

» store number of FAT sectors 

ret 


; into (word ptr bpb+0bh) 

setup endp 

format proc 

near 

; format the EMSDISK area 
; returns CY = clear if successful 
; CY « set if error 

mov 

bx, 0 

; first clear EMSDISK area 

fmtl: cmp 

bx,owned_pages 

; done with all EMS pages? 

je 

fmt2 

; yes, jump 

push 

bx 

; save current page number 

mov 

ax,4400h 

; map to physical page 0 

mov 

dx,emm_handle 

; get our process id 

Int 

67h 

; request mapping by EMM 

pop 

bx 

; restore page number 

or 

ah ,ah 

; if bad mapping give up 
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fmt2: 


jnz 

f mt9 

; (should never happen) 

mov 

es,page_f rame 

; set ES:DI = EMS page 

xor 

di ,di 


mov 

cx,page_size 

; page length 

xor 

cld 

a I, a 1 

; fill page with zeros 

rep 

stosb 


inc 

bx 

; increment page and loop 

jmp 

fmtl 



; copy phony boot sector with 
; Bios Parameter Block to 
; EMSDISK’s logical sector 0 


mov 

ax ,0 

; map in logical sector 0 

ca 1 1 

map_sec 

; jump if mapping error 

jc 

f mt9 

mov 

di ,ax 

; let ES:DI * point to sector 0 

mov 

es,page_frame 

; let DS:SI point to boot rec. 

mov 

si .offset boot_ 

rec 

mov 

cx,boot_rec_len 

; CX * length to copy 

rep 

movsb 

; now transfer boot sector 

mov 

ax, 1 

; map in EMSDISK logical 

ca 1 1 

map_sec 

; sector 1 (first sec of FAT) 

jc 

f mt9 

; jump if mapping error 

mov 

di ,ax 


mov 

es,page_frame 

; ES:DI points to sector 1 

; put media descriptor into FAT 
; byte 0, bytes 1-2 must be -1 

mov 

al,byte ptr [bpb+0ah] 

mov 

es:[diJ,al 


mov 

word ptr es:[di+1],-1 


; now set up EMSDISK volume label. 
; first directory sector* 

; number of FATs*length of FAT 
; plus no. of reserved sectors 
mov al,byte ptr [bpb+5] 

xor ah,ah 

mu I word ptr [bpb+0bh] 

add ax,word ptr [bpb+3] 

call map_sec ; map in first directory block 

jc fmt9 ; Jump if mapping error 

mov di,ox ; copy volume label to directory 

mov es,page_frame 

mov si,offset vol_name 

mov cx,vol_name_len 



rep movsb 



c 1 c 
ret 


; CY * clear, format successful 

fmt9: 

stc 

ret 


; CY * set if error during format 

format 

endp 



get_kb 

proc 

near 

; get desired size of EMSDISK 
; in Kbytes from CONFIG.SYS line, 

; sets "req_pages" and "owned_pages" 
; if no disk size requested by user, 

; makes largest possible EMSDISK. 


mov si,offset cmd_line 


getkbl: lodsb 

or al,al 

Jz getkb9 


scan for end of driver name 
if zero, no Kbytes requested 


{continued) 
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getkb2 


getkb3: 

getkb4: 

getkb9: 

get_kb 
signon 


cmp 

al,blank 

jne 

getkbl 

lodsb 

or 

a 1 , a 1 

Jz 

getkb9 

cmp 

al,blank 

je 

getkb2 

dec 

s I 

cal 1 

ascbIn 

or 

ox, ax 

Jz 

getkb9 

mov 

dx, ax 

mov 

cx,4 

shr 

ax, cl 

and 

dx,0fh 

jz 

getkb3 

i nc 

ax 

mov 

req_pages,ax 

cmp 

ax,ovail_pages 

Jna 

getkb4 

mov 

ax,avall_pages 

mov 

ret 

owned_pages,ax 

mov 

ax,avail_pages 

mov 

req_pages,ax 

mov 

ret 

owned_pages,ax 

endp 

proc 

near 

1 es 

<Ji. [rh_ptr] 

mov 

ol,es:[di+22] 

add 

a 1,'A* 

mov 

drv_code,al 

mov 

ax.cs 

mov 

bx,offset dh_add 

cal 1 

hexasc 

mov 

ax,total_pages 

mov 

dx, 16 

mu 1 

dx 

mov 

cx ,10 

mov 

s i .offset k b_ins 

ca 1 1 

b i nasc 

mov 

ax,avaI1 pages 

mov 

dx. 16 

mu 1 

dx 

mov 

CX.10 

mov 

s i ,of fset kb_ava 

ca 1 1 

b i nasc 

mov 

ax,owned pages 

mov 

dx, 16 

mu 1 

dx 

mov 

cx, 10 

mov 

si,offset kb_ass 

cal 1 

binasc 

mov 

ah, 9 

mov 

dx,offset ident 

int 

21 h 

mov 

dx,offset dos2m 

cmp 

dos_ver,2 

je 

signonl 

mov 

dx,offset dos3m 


If blank, reached end of name 


scan for start of Kbytes field 
If zero found, no Kbytes requested 

if blank, keep searching 


point to start of field and 
convert string to binary Kbytes 
if request-0, make big disk 

save copy of Kbytes 

divide Kbytes by 16 to get 

requested EMS pages 

round up needed? 

jump if multiple of 16 Kbytes 


; save requested EMS pages 
; compare with pages available 
; jump if ok 

; request too large, use avail, only 


no size requested by user, set 
requested and owned to maximum possible. 


format and print driver ident. 

let ES:DI - Request Header, 
get drive code from header, 
convert it to ASCII, and 
store into sign-on message 

convert load address to ASCII 


format Kbytes of EM Installed 
pages * 16 - Kbytes 
a Iled+3 

convert Kbytes to ASCII 
format Kbytes of EM available 
pages * 16 « Kbytes 
1+3 

convert Kbytes to ASCII 

format Kbytes assigned to EMSDISK 

pages * 16 - Kbytes 


; convert Kbytes to ASCII 

; print sign-on message 
; and copyright notice 


check DOS version, if 

DOS 2 can * t know drive letter 

if DOS 3 can display drive 
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signonl: 


mov 

ah, 9 

; print load address, bytes 

int 

21h 

; in EMSDISK, etc. 

ret 


; back to caller 

signon endp 



i dent 

db 

cr. If, If 


db 

‘Expanded Memory EMSDISK 1.0* 


db 

cr, 1 f 


db 

‘Copyright (C) 1986 Ray Duncan* 


db 

cr. If,If,eom 

dos3m 

db 

‘EMSDISK will be drive ’ 

drv_code 

db 

‘X: * 


db 

cr, 1 f 

dos2m 

db 

‘Device driver loaded at * 

dh_addr 

db 

*XXXX:0000* 


db 

cr, If, If 

kb_insta11ed 

db 

* Kbytes Expanded Memory installed.* 


db 

cr, 1 f 

kb_avai1 

db 

* Kbytes Expanded Memory available.* 


db 

cr, 1 f 

kb_assigned 

db 

* Kbytes assigned to EMSDISK.’ 


db 

cr , 1f,eom 

emm_name 

db 

’EMMXXXX0*,0 ; device name for Expanded 



; Memory Manager 

ermsg 

db 

cr, 1 f 

db 

*EMS RAMDISK installation error:* 


db 

cr,1f,eom 

msgl 

db 

’Expanded Memory Manager not found.* 

db 

cr,1f,eom 

msg2 

db 

‘Expanded Memory not functional.* 

db 

cr,1f,eom 

msg3 

db 

‘Expanded Memory Manager error.* 

db 

cr,1f,eom 

msg4 

db 

‘No Expanded Memory pages available.* 

db 

cr,1f,eom 

msg5 

db 

’Expanded Memory allocation failed.* 

db 

cr , 1f,eom 

msg6 

db 

‘Wrong Expanded Memory Manager version.* 

db 

cr , 1f,eom 

msg7 

db 

‘Unable to format EMSDISK.* 

db 

cr , 1 f,eom 



; phony volume label, copied to 
; EMSDISK’s first directory sectoi 

vol_name 

db 

‘EMS_RAMDISK* 


db 

08h ; volume label attribute byte 


db 

10 dup (0) 


dw 

0 ; time 


dw 

0cb0h ; date = May 16, 1986 


db 

6 dup (0) 

vol_name_len 

equ 

$-vol_name 

page 




HEXASC: convert a binary 16-bit number into 
a "hexadecimal" ASCII string. 


Call with AX ■ value to convert 

DS:BX - address to store 4-character string 


(continued) 
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; Returns 
» 

hexasc proc 


AX, BX destroyed, other registers preserved 
near 


push 

CX 

; save registers 

push 

dx 

mov 

dx,4 

; initialize character counter 

hexascl: 

mov 

cx,4 

; isolate next four bits 

rol 

ox, cl 


mov 

cx.ax 


and 

cx,0fh 


add 

CX,’0’ 

; convert to ASCII 

cmp 

CX, *9* 

; is it 0-9? 

jbe 

hexasc2 

; yes, jump 

add 

cx,*A’-'9*-1 

; add fudge factor for A-F 

hexasc2: 

[bx],c1 

; store this character 

mov 


i nc 

bx 

; bump string pointer 

dec 

dx 

; count characters converted 

jnz 

hexascl 

; loop, not four yet 

pop 

dx 

; restore registers 

pop 

cx 

ret 


; back to cal 1er 

hexasc endp 


/ 


BINASC: Convert 32 bit binary value to ASCII string. 


Cal I with DX:AX 
CX 
SI 


signed 32 bit value 
radix 

last byte of area to store resulting string 
(make sure enough room is available to store 
the string in the radix you have selected.) 


Destroys AX, BX, CX, DX, and SI. 


b 1 nasc 

proc 

near 


mov 

byte ptr [si] 


or 

dx.dx 


pushf 

Jns 

binl 


not 

dx 


not 

ax 


add 

ax, 1 


adc 

dx, 0 

binl: 

mov 

bx,ax 


or 

bx,dx 


jz 

bin3 


ca 1 1 

divide 


add 

bl,* 0 * 


cmp 

bl,*9’ 


jle 

bin2 


add 

bl,*A*-'9'-1 

b i n 2: 

mov 

[si].bl 


dec 

s i 


jmp 

binl 

bin3: 

popf 

jns 

b i n4 

bin4: 

mov 

byte ptr [si], 

ret 


convert DX:AX to ASCII. 

force storage of at least 1 digit. 

test sign of 32 bit value, 

and save sign on stack. 

jump if it was positive. 

it was negative, take 2’s complement 

of the value. 


divide the 32 bit value by the radix 
to extract the next digit for the 
forming string, 
is the value zero yet? 

yes, we are done converting. 

no, divide by radix. 

convert the remainder to an ASCII dig 

we might be converting to hex ASCII, 

jump if in range 0-9, 

correct it if in range A-F. 

store this character into string. 

back up through string, 

and do it again. 

restore sign flag, 

was original value negative? 

no, jump 

yes,store sign into output string, 
back to caller. 


t. 


binasc endp 
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General purpose 32 bit by 16 bit unsigned divide. 

This must be used instead of the plain machine unsigned divide 
for cases where the quotient may overflow 16 bits (for example, 
dividing 100,000 by 2). If called with a zero divisor, this 
routine returns the dividend unchanged and gives no warning. 


Call with DX:AX = 32 bit dividend 

CX * divisor 

Returns DX:AX * quotient 
BX = remainder 

CX * divisor (unchanged) 


divide 

proc 

near 

• 


jcxz 

divl 

» 


push 

ax 

» 


mov 

ax, dx 



xor 

dx, dx 



di v 

cx 



mov 

bx,ax 

; 


pop 

ax 

; 


di v 

cx 



xchg 

bx,dx 

• 

divl: 

ret 



divide 

endp 




Divide DX:AX by CX 

exit if divide by zero 
0:dividend_upper/divisor 

BX = quotientl 

remainder1:dividend_lower/divisor 
DX:AX = quotient1:quotient2 
BX = remainder2 


ASCBIN: Convert decimal ASCII string to unsigned binary integer. 
Conversion ends on first byte not |'0'...'9 , J. 

Call with DS:SI « addr of ASCII string 

Returns AX * unsigned binary integer 

DS:SI points to unconvertab Ie character + 1 

ascbin 


ascbini 


ascbin2: 


proc 

near 



push 

dx ; 

save prev. register contents 


xor 

dx,dx ; 

set forming answer to zero 


lodsb 

» 

get next character from input 

string 

cmp 

a 1,’9’ ; 

make sure it is legal character 0-9. 

ja 

ascbin2 ; 

char > *9*, exit with error f 

1 ag. 

cmp 

al,’0’ 



jb 

a$cbin2 ; 

; char < *0 , exit with error flag. 

push 

ax ; 

save character from string 


mov 

ax,10 ; 

; multiply prev answer * 10 


mu 1 

dx ; 

; low part of answer*10 now in 

AX 

pop 

dx 



and 

dx,0fh 

isolate binary value 0-9 


add 

dx,ax 

accumulate forming answer 


jmp 

ascbinl 

get next character 




end of conversion, 


mov 

ax, dx 

return answer in AX 


pop 

dx 

and restore register DX. 


ret 





ascbin endp 


code ends 
end 
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PI.BAS 

"IBM PC Accelerators," by Stephen S. Fried. Inside 
the IBM PCs, Extra Edition, page 140. 


10 REM PI.BAS — Performance Index Benchmark Program 
20 REM Copyright (C) MicroWay, Inc., 1986 

30 REM MicroWay, Inc. PO Box 79 Kingston MA 02364 (617) 746-7341 

40 REM 

50 REM Does not use Numeric Coprocessor (8087 or 80287). See PI87.BAS for 
60 REM a similar program which does use the Numeric Coprocessor. 

70 REM Compiled with IBM BASIC Compiler V2.00 (/0 switch). Linked with 
80 REM assembly language subroutines: 

90 REM DBB4 DBBCACHE DBB16 CB4 CB16 IA XFER TIME100 
100 REM 

110 DEFINT A-Y 

120 DIM NAMES (11), SECTIONS (11), ZF (11), ZP (11) 

130 DIM DSRC (10249), DDEST (10249) 

140 COMMON DSRC (), DDEST “ 

150 DEF FNS# (X$) - 60# * 


(). SPC1!, SPC2!, SPC3I, SVAI, SVB! 
(60# * VAL (MIOS (X$, 1. 2)) + 


VAL (MID$ (X$, 4, 2))) + VAL (MID$ (X$. 7, 2)) + .01# * 
160 LINESS = "" : FOR I = 1 TO 69 : LINESS » LINESS + CHR$ 


(205) : NEXT I 


170 PRINT CHR$ (201); LINESS; CHR$ (187) 

180 PRINT CHR$ (186); "MicroWay 
Performance Index P 
190 PRINT CHR$ (200); LINESS; CHR$ (188) 

Copyright (C) MicroWay, Inc., 1986." 

(This version does not use the Numeric Coprocessor)" 


r o g r a m 


CHR$ (186) 


200 PRINT 
210 PRINT 
220 PRINT 

230 DATA 0.6013,0.5607,0.6,0.6,0.595,0.589,0.62,0.6,0.6,0.6064,0.6064 
240 DATA " 1"," 2"," 3"," 4"," 5"," 6"," 7"," 8"," 9","10" "11" 

250 DATA "Floating point — arithmetic* * * M 

260 DATA "Floating point — Savage (transcendentaIs) 

270 DATA "Data bus bound — 4K bytes of instructions " 

280 DATA "Data bus bound — 4K bytes of register moves " 

290 DATA "Data bus bound — 16K bytes of instructions " 

300 DATA "Clock bound — 4K byte block moves " 

310 DATA "Clock bound — 16K byte block moves " 

320 DATA "Integer multiply and divide " 

330 DATA "Subroutine calls and stack operations " 

340 DATA "Disk I/O — sequential read from random file " 

350 DATA "Disk I/O — sequential write to random file " 

370 CALL 1 * 1111 11» 11 * 1111 1 1 , 11 . 111111 ,8.333333,8.333333,0,0,0,0 

380 FIRSTTIME = 1 
390 FOR I = 1 TO 11 

400 FOR I = 1 TO 11 

410 FOR I = 1 TO 11 

420 FOR I = 1 TO 11 

430 MAXWRITES = 20 
440 GOTO 570 

450 REM *** Create file so that reads will have something to work on 

460 REM *** and so that writes will not have to create new records 

470 IF MAXWRITES > MAXREADS THEN MPUT = MAXWRITES : ELSE MPUT = MAXREADS 
480 OPEN “TEMP.TMP" FOR RANDOM AS #1 LEN=2048 
490 FIELD #1. 2048 AS S$ 

f 00 JL* 11 : F0R 1=0 T0 1023 : T$ « T$ + MKI$ (256 * RNO (I)) : NEXT I 
510 LSET S$ = T$ 

520 FOR I = 1 TO MPUT : PUT #1, I : NEXT I : CLOSE #1 

530 PRINT "Please enter percentage of benchmark devoted to each operation 1 
540 FOR 1=1 TO 11 

550 PRINT “Section “;SECTION$ (I);" “;NAMES (I);": "; : INPUT ZP (I) 

560 NEXT I ' ’ 

570 ZT = 0 : FOR I = 1 TO 11 : ZT = ZT + ZP (I) : NEXT I 

580 IF ZT > 99.5 AND ZT < 100.5 THEN GOTO 640 

590 PRINT : PRINT "Caution: percentages total "; ZT; 

600 INPUT " Adjust to 100% ? ", ADJ$ : PRINT : ADJ$ » 

610 IF ADJ$ - "Y" OR ADJ$ = "y" THEN GOTO 630 

620 IF ADJ$ = "N" OR ADJ$ = "n" THEN GOTO 660 : ELSE GOTO 600 

630 IF ZT = 0! THEN GOTO 840 
640 Z100 - 1# / ZT : FOR I - 1 TO 11 : ZP (I) 


: READ ZF (I) 

: READ SECTIONS (I) 
: READ NAMES (I) 

: READ ZP (I) 
MAXREADS = 20 


NEXT I 
NEXT I 
NEXT I 
NEXT I 


LEFTS (ADJS. 1) 


650 ZT « 100# : GOTO 670 
660 FOR I = 1 TO 11 ': ZP (I) 


ZP (I) * Z100 : NEXT I 


.01 * ZP (I) : NEXT I 
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670 PRINT "Section Description Performance Index" 

$80 PRINT — mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm «================" 

690 ZTET = 0# : FOR J = 1 TO 11 
700 ZITER - 60# * ZP (J) / ZF (J) 

710 ITER = INT (ZITER) : IF ZITER - ITER > .1 THEN ITER - ITER + 1 
720 REM 1 23456789 10 11 

730 ON J GOSUB 930,970,1000.1010,1020,1030,1040,1050,1060,1070,1140 
740 ZET » FNS# (8$) - FNS# (A$) 

750 IF ITER <> 0 THEN ZET = ZET * ZITER / ITER : ELSE ZET = 0# 

760 PRINT " ";SECTION$ (J);" ";NAMES (J);" 

770 IF ZET » 0 THEN PRINT " -" : GOTO 790 

780 PRINT USING "###.##"; ZF (J) * ZITER / ZET 
790 ZTET = ZTET + ZET 
800 NEXT J 

810 PRINT : PRINT "Performance Index for entire benchmark is "; 

820 IF ZTET = 0 THEN PRINT "not meaningful." : GOTO 840 
830 PRINT USING "###.##"; .6# * ZT / ZTET 
840 PRINT 

850 INPUT "Would you like to run again, specifying the 

section weights yourself? ", MORE$ : MORES “ LEFTS (MORES 
860 IF MORES - "Y" OR MORES = "y" THEN GOTO 900 

870 IF MORES = "N" OR MORES - "n" THEN GOTO 880 : ELSE GOTO 840 

880 IF FIRSTTIME > 1 THEN KILL "TEMP.TMP" 

890 END 

900 PRINT : FIRSTTIME - FIRSTTIME + 1 

910 IF FIRSTTIME = 2 THEN GOTO 450 : ELSE GOTO 530 

920 REM *** Arithmetic (common subexpressions) 

930 A$ = TIMES : FOR I = 1 TO ITER : ZA# = 0# : FOR K = 1 TO 114 

940 ZB# = (ZA# + 1#) * (ZA# + 2#) / (ZA# + 3#) + 

(ZA# + 2#) * (ZA# + 3#) / (ZA# + 1#) + (ZA# + 3#) * (ZA# + 1#) 

950 NEXT K : NEXT I : B$ - TIMES : RETURN 

960 REM *** Savage (transcendentals and trigonometries) 

970 AS - TIMES : FOR I = 1 TO ITER : ZA# = 1# : FOR K - 1 TO 9 
980 ZA# - TAN (ATN (EXP (LOG (SQR (ZA# * ZA#))))) + 1# 

990 NEXT K : NEXT I : B$ - TIMES : RETURN 

1000 A$ - TIMES : FOR I - 1 TO ITER : CALL DBB4 : NEXT I : B$ - TIMES : RETURN 

1010 AS - TIMES : FOR I - 1 TO ITER : CALL DBBCACHE:NEXT I: B$ - TIMES : RETURN 


1020 

A$ 

X 

TIMES : FOR 

I 

B 

1 

TO 

ITER 

: CALL 

DBB16 

NEXT 

I 

: B$ 

S 

TIMES : RETURN 

1030 

A$ 

s 

TIMES : FOR 

I 

=s 

1 

TO 

ITER 

: CALL 

CB4 

NEXT 

I 

: B$ 

= 

TIMES : RETURN 

1040 

A$ 

s 

TIMES : FOR 

I 

= 

1 

TO 

ITER 

: CALL 

CB16 

NEXT 

I 

: 8$ 

= 

TIMES : RETURN 

1050 

A$ 

B 

TIMES : FOR 

I 

■ 

1 

TO 

ITER 

: CALL 

IA 

NEXT 

I 

: B$ 

* 

TIMES : RETURN 

1060 

A$ 

m 

TIMES : FOR 

I 

s 

1 

TO 

ITER 

: CALL 

XFER 

NEXT 

I 

: B$ 

B 

TIMES : RETURN 


1070 REM *** Random reads 

1080 IF ITER = 0 THEN A$«TIME$ : B$=A$ : RETURN 
1090 OPEN "TEMP.TMP" FOR RANDOM AS #1 LEN=2048 
1100 FIELD #1, 2048 AS S$ 

1110 A$ = TIMES 

1120 FOR K * 1 TO ITER : FOR I = 1 TO MAXREADS : GET #1, I : NEXT I : NEXT K 
1130 B$ = TIMES : CLOSE #1 : RETURN 
1140 REM *** Random writes 

1150 IF ITER - 0 THEN AS=TIME$ : B$=A$ : RETURN 
1160 OPEN "TEMP.TMP" FOR RANDOM AS #1 LEN=2048 
1170 FIELD #1, 2048 AS S$ : LSET S$ - T$ 

1180 A$ = TIMES 

1190 FOR K = 1 TO ITER : FOR I - 1 TO MAXWRITES : PUT #1, I : NEXT I : NEXT K 
1200 B$ = TIMES : CLOSE #1 : RETURN 


PI187.BAS 

"IBM PC Accelerators," by Stephen S. Fried. Inside 
the IBM PCs, Extra Edition, page 140. 


10 REM PI87.BAS — Performance Index Benchmark Program 
20 REM Copyright (C) MlcroWoy, Inc., 1986 

30 REM MlcroWoy, Inc. PO Box 79 Kingston MA 02364 (617) 746-7341 

40 REM 

50 REM Uses Numeric Coprocessor (8087 or 80287). See PI.BAS for a similar 
60 REM program which doesn’t use the Numeric Coprocessor. 

70 REM Compiled with MlcroWoy 87BASIC Compiler V5.05 (/O switch) and linked 
80 REM with special library based on MicroWay 87BASIC/INLINE. 

90 REM 

100 DEFINT A-Y 

[continued) 
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110 DIM NAME$ (11), SECTIONS (11), ZF (11), ZP (11) 

120 DIM DSRC (10249), DDEST (10249) 

130 COMMON DSRC (), DDEST (), SPC1!, SPC2I, SPC3!, SVA!, SVB! 

140 DEF FNS# (X$) - 60# * (60# * VAL (MID$ (X$, 1, 2)) + 

VAL (MID$ (X$, 4, 2))) + VAL (MID$ (X$, 7, 2)) + .01# * 

150 LINESS - : FOR I - 1 TO 69 : LINES$ - LINESS + CHR$ (205) : NEXT I 

LINES$; CHR$ (187) 

“MlcroWoy 

monce Index Proarom"; CHR$ (186) 


160 PRINT CHR$ (201); 
170 PRINT CHR$ (186); 
P e r f o r 


LINESS; CHR$ (188) 

Copyright (C) MicroWoy, Inc., 1986." 

(This version uses the Numeric Coprocessor.)" 


180 PRINT CHRS (200); 

190 PRINT " 

200 PRINT " 

210 PRINT 

220 DATA 0.6,0.6,0.6,0.6,0.595,0.589,0.62,0.6,0.6,0.6064,0.6064 
230 DATA " 1"," 2"," 3"," 4"," 5"," 6"," 7"." 8",*' 9","10","11" 

240 DATA "Floating point — arithmetic " 

250 DATA "Floating point — Savage (transcendentals) " 

260 DATA "Data bus bound — 4K bytes of instructions " 

270 DATA "Data bus bound — 4K bytes of register moves " 

280 DATA "Data bus bound — 16K bytes of instructions " 

290 DATA "Clock bound — 4K byte block moves " 

300 DATA "Clock bound -- 16K byte block moves " 

310 DATA "Integer multiply and divide " 

320 DATA "Subroutine calls and stack operations ” 

330 DATA "Disk I/O — sequential read from random file " 

340 DATA "Disk I/O — sequential write to random file " 

350 DATA 25,25,11.111111,11.111111,11.111111,8.333333.8.333333,0,0,0,0 
360 CALL TIME 100 


370 FIRSTTIME - 1 
380 FOR I - 1 TO 11 

390 FOR I = 1 TO 11 

400 FOR I - 1 TO 11 

410 FOR I - 1 TO 11 

420 MAXWRITES = 20 : 
430 GOTO 560 


READ ZF (I) : NEXT I 

READ SECTIONS (I) : NEXT I 
READ NAMES (I) : NEXT I 

READ ZP (I) : NEXT I 

MAXREADS = 20 


440 REM *** Create file so that reads will have something to work on 
450 REM *** and so that writes will not have to create new records 
460 IF MAXWRITES > MAXREADS THEN MPUT = MAXWRITES : ELSE MPUT » MAXREADS 
470 OPEN "TEMP.TMP" FOR RANDOM AS #1 LEN=2048 
480 FIELD #1, 2048 AS S$ 

490 T$ = "" : FOR 1-0 TO 1023 ; T$ - T$ + MKI$ (256 * RND (I)) : NEXT I 
500 LSET SS - T$ 

510 FOR I - 1 TO MPUT : PUT #1. I : NEXT I : CLOSE #1 

520 PRINT "Please enter percentage of benchmark devoted to each operation." 
530 FOR I - 1 TO 11 

540 PRINT "Section ";SECTION$ (I);" ";NAMES (I);": “; : INPUT ZP (I) 

550 NEXT I 

560 ZT = 0 ; FOR I = 1 TO 11 : ZT - ZT + ZP (I) : NEXT I 

570 IF ZT > 99.5 AND ZT < 100.5 THEN GOTO 630 

580 PRINT : PRINT "Caution; percentages total “; ZT; 

590 INPUT " Adjust to 100% ? ", ADJ$ : PRINT : ADJ$ = LEFTS (ADJ$. 1) 

600 IF ADJ$ = "Y" OR ADJ$ = "y" THEN GOTO 620 

610 IF ADJ$ = "N" OR ADJ$ = "n" THEN GOTO 650 : ELSE GOTO 590 

620 IF ZT = 0! THEN GOTO 830 

630 Z100 = 1# / ZT ; FOR I = 1 TO 11 : ZP (I) - ZP (I) * Z100 : NEXT I 
640 ZT = 100# : GOTO 660 

650 FOR I = 1 TO 11 : ZP (I) = .01 * ZP (I) ; NEXT I 

660 PRINT "Section Description Performance 

670 PRINT "=“»“= -=———mm ESS BBS===*===========*============ == _____ ==== . 

680 ZTET = 0# : FOR J - 1 TO 11 
690 ZITER = 60# * ZP (J) / ZF (J) 

700 ITER = INT (ZITER) : IF ZITER - ITER > .1 THEN ITER = ITER + 1 
710 REM 1 2 3 4 5 6 7 8 9 10 11 

720 ON J GOSUB 910,920,930,940,950.960,970,980,990,1000,1070 
730 ZET = FNS# (B$) - FNS# (A$) 

740 IF ITER <> 0 THEN ZET - ZET * ZITER / ITER : ELSE ZET - 0# 

750 PRINT " ";SECTIONS (J);" ";NAMES (J);" "; 

760 IF ZET - 0 THEN PRINT “ -" : GOTO 780 

770 PRINT USING "###.##"; ZF (J) * ZITER / ZET 
780 ZTET = ZTET + ZET 
790 NEXT J 

800 PRINT : PRINT "Performance index for entire benchmark is “; 

810 IF ZTET - 0 THEN PRINT "not meaningful." : GOTO 830 
820 PRINT USING "###.##"; .6# * ZT / ZTET 
830 PRINT 


Index" 
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840 INPUT "Would you like to run ogoin, specifying the 

section weights yourself? ", MORES : MORE$ ■ LEFT$ (MORE$ 
850 IP MORES - "Y" OR MORES - "y" THEN GOTO 890 
860 IF MORES - "N" OR MORES - "n" THEN GOTO 870 : ELSE GOTO 830 
870 IF FIRSTTIME > 1 THEN KILL "TEMP.TMP" 

880 END 

890 PRINT : FIRSTTIME = FIRSTTIME + 1 


900 

IF 

FIRSTTIME 

- 2 

THEN 

GOTO 

440 

: ELSE 

GOTO 520 

: B$ 


TIMES 


910 

A$ 

9 

TIMES 


FOR 

I 

9 

1 

TO 

ITER 

: CALL 

FPCSE : NEXT I 

= 

: RETURN 

920 

A$ 

S 

TIMES 

• 

FOR 

I 

9 

1 

TO 

ITER 

: CALL 

FPSAV : NEXT I 

: B$ 

= 

TIMES 

: RETURN 

930 

A$ 

S 

TIMES 


FOR 

I 

= 

1 

TO 

ITER 

: CALL 

DBB4 : NEXT I 

: B$ 

« 

TIMES 

: RETURN 

940 

A$ 

9 

TIMES 


FOR 

I 

9 

1 

TO 

ITER 

: CALL 

DBBCACHE:NEXT I: B$ 

= 

TIMES 

: RETURN 

950 

A$ 

S 

TIMES 

: 

FOR 

I 

9 

1 

TO 

ITER 

: CALL 

DBB16 : NEXT I 

: B$ 

= 

TIMES 

: RETURN 

960 

A$ 

2 

TIMES 

: 

FOR 

I 

S 

1 

TO 

ITER 

: CALL 

CB4 : NEXT I 

: 8$ 

= 

TIMES 

: RETURN 

970 

A$ 

9 

TIMES 


FOR 

I 

= 

1 

TO 

ITER 

: CALL 

CB16 : NEXT I 

: B$ 

s 

TIMES 

: RETURN 

980 

A$ 

9 

TIMES 


FOR 

I 

9 

1 

TO 

ITER 

: CALL 

IA : NEXT I 

: B$ 

s 

TIMES 

: RETURN 

990 A$ * 
1000 REM 
1010 IF 

TIMES : FOR I - 1 TO ITER : CALL 
*** Random reads 

ITER = 0 THEN A$=TIME$ : B$=A$ : 1 

XFER : NEXT I 

RETURN 

: B$ 


TIMES 

: RETURN 


1020 OPEN "TEMP.TMP" FOR RANDOM AS #1 LEN=2048 
1030 FIELD #1, 2048 AS S$ 

1040 A$ - TIMES 

1050 FOR K = 1 TO ITER : FOR I «= 1 TO MAXREADS : 
1060 B$ = TIMES : CLOSE #1 : RETURN 
1070 REM *** Random writes 

1080 IF ITER - 0 THEN A$=TIME$ : B$«=A$ : RETURN 
1090 OPEN "TEMP.TMP" FOR RANDOM AS #1 LEN-2048 
1100 FIELD #1. 2048 AS S$ : LSET S$ = T$ 

1110 AS = TIMES 

1120 FOR K = 1 TO ITER : FOR I - 1 TO MAXWRITES 
1130 B$ = TIMES : CLOSE #1 : RETURN 


GET #1.1: NEXT I : NEXT K 


PUT #1.1: NEXT I : NEXT K 


FPCSE.ASM 

"IBM PC Accelerators," by Stephen S. Fried. Inside 
the IBM PCs, Extra Edition, page 140. 


NAME FPCSE 

; Floating point — arithmetic (common subexpressions) 

; Assembly language subroutine source for PI program. 

; Provided to Byte Magazine by: 

; MicroWay, Inc. 

; PO Box 79 
; Kingston MA 02364 

; (617) 746-7341 

; Copyright (C) MicroWay, Inc., 1986. 


.8087 



PUBLIC 

FPCSE 


DGROUP 

GROUP 

COMMON 

COMMON 

SEGMENT 

PARA COMMON ’BLANK 

_DSRC 

DW 

10240 DUP (?) 

JDDEST 

DW 

10240 DUP (?) 

SPC$1_ 

DD 

1 .0 

SPC$2_ 

DD 

2.0 

SPC$3_ 

DD 

3.0 

SV$A 

DD 

0.0 

SV$B 

DD 

? 

COMMON 

ENDS 


CODE 

SEGMENT 

WORD PUBLIC ’CODE* 


[continued) 
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ASSUME CS:CODE, DSiDGROUP, ES:DGROUP, SS:DGROUP 
FPCSE PROC FAR 

MOV CX.2205 

INNER: 

; Start of test code 


FINIT 



FLD 

DWORD PTR 

< 

</> 

> 

(/> 

FLD 

ST(0) 


FADD 

DWORD PTR 

SPC$1_ 

FSTP 

ST(2) 


FLD 

ST(0) 


FADD 

DWORD PTR 

SPC$2_ 

FSTP 

ST(3) 


FLD 

ST (1) 


FMUL 

ST,ST(3) 


FSTP 

ST 4 


FLD 

ST (0) 


FADD 

DWORD PTR 

SPC$3_ 

FSTP 

ST(5) 


FLD 

ST(3) 


FDIV 

ST,ST(5) 


FSTP 

ST(4) 


FLD 

ST(2) 


FMUL 

ST,ST(5) 


FDIV 

ST.ST(2) 


FADD 

ST,ST(4) 


FSTP 

ST(4) 


FLD 

ST(4) 


FMUL 

ST,ST(2) 


FDIV 

ST,ST(3) 


FADD 

ST,ST(4) 


FST 

DWORD PTR 

SV$B 

test 

code 


LOOP 

SINNER 



RET 

SINNER: JMP INNER 
FPCSE ENDP 
CODE ENDS 
END 


FPSAV.ASM 

"IBM PC Accelerators," by Stephen S. Fried. Inside 
the IBM PCs, Extra Edition, page 140. 


NAME FPSAV 

; Floating point — Savage (transcendentaIs and trigonometries) 

; Assembly language subroutine source for PI program. 

; Provided to Byte Magazine by: 

; MicroWay, Inc. 

; PO Box 79 
; Kingston MA 02364 

; (617) 746-7341 

; Copyright (C) MicroWay, Inc., 1986. 

.8087 

PUBLIC FPSAV 

EXTRN $LOD$I:FAR 
EXTRN $EXD$I:FAR 
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EXTRN 

$ATD$I:FAR 

EXTRN 

$TAD$I:FAR 

DGROUP 

GROUP 

COMMON 

COMMON 

SEGMENT 

PARA COMMOh 

_DSRC 

DW 

10240 DUP 1 

_DDEST 

DW 

10240 DUP 1 

SPC$1_ 

DD 

1.0 

SPC$2_ 

DD 

2.0 

SPC$3_ 

DD 

3.0 

SV$A 

DD 

0.0 

SV$B 

DD 

? 

COMMON 

ENDS 


CODE 

SEGMENT 

WORD PUBLI( 

ASSUME 

CS:C0DE 

, DS:DGROUP 

FPSAV 

PROC 

FAR 


’BLANK* 


MOV 

FINIT 

FLD1 

AGAIN: FMUL 
FSQRT 
CALL 
CALL 
CALL 
CALL 
FLD1 
FADDP 
LOOP 

RET 

FPSAV ENDP 


CX.476 


ST,ST(0) 

$LOD$I 

$EXD$I 

$ATD$I 

$TAD$I 

ST(1),ST 
AGAIN 


CODE 


ENDS 

END 


DBB4.ASM 

"IBM PC Accelerators," by Stephen S. Fried. Inside 
the IBM PCs, Extra Edition, page 140. 


NAME DBB4 

; Data bus bound — 4K bytes of instructions 

; Assembly language subroutine source for PI program. 
; Provided to Byte Magazine by: 

; MicroWay, Inc. 

; PO Box 79 
; Kingston MA 02364 

: (617) 746-7341 

; Copyright (C) MicroWay, Inc., 1986. 


PUBLIC 

DBB4 


DGROUP 

GROUP 

COMMON 

COMMON 

SEGMENT 

PARA COMMON ’BLANK 

_DSRC 

DW 

10240 DUP (?) 

JDDEST 

DW 

10240 DUP (?) 


[continued) 
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SPC$1_ 

DD 

1.0 

SPC$2_ 

DD 

2.0 

SPC$3_ 

DD 

3.0 

SV$A 

DD 

0.0 

SV$B 

DD 

? 

COMMON 

ENDS 


CODE 

SEGMENT 

WORD PUBLIC 

ASSUME 

CS:C0DE 

, DS:DGROUP 

DBB4 

PROC 

FAR 

INNER: 

MOV 

CX,161 

; Start 

of test 

code 

REPT 

256 



XOR 

AX. AX 


XOR 

DX.DX 


ADD 

AX.DX 


ADD 

AX.DX 


SUB 

AX.DX 

ENDM 

SUB 

CLC 

CLD 

NOP 

NOP 

AX.DX 

; End of test code 


LOOP 

RET 

$INNER 

SINNER: 

JMP 

INNER 

DBB4 

ENDP 


CODE 

ENDS 

END 



DBB16.ASM 

"IBM PC Accelerators," by Stephen S. Fried. Inside 
the IBM PCs, Extra Edition, page 140. 


NAME DBB16 

; Data bus bound — 16K bytes of Instructions 

; Assembly language subroutine source for PI program. 
; Provided to Byte Magazine by: 

; MlcroWay, Inc. 

; PO Box 79 
; Kingston MA 02364 

; (617) 746-7341 


; Copyright (C) 

PUBLIC DBB16 

MicroWay, Inc., 1986 

DGROUP 

GROUP 

COMMON 

COMMON 

SEGMENT 

PARA COMMON ’BLANK* 

_DSRC 

DW 

10240 DUP (?) 

JDDEST 

DW 

10240 DUP (?) 

SPC$1_ 

DD 

1.0 

SPC$2 

DD 

2.0 
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SPC$3_ 

DD 

3.0 

SV$A 

DD 

0.0 

SV$B 

DD 

? 

COMMON 

ENDS 


CODE 

SEGMENT 

WORD PUBLIC 

ASSUME 

CSiCODE, 

, DS:DGROUP 

DBB16 

PROC 

FAR 


MOV 

CX, 40 

INNER: 



; Start 

of test 

code 

REPT 

1024 



XOR 

AX, AX 


XOR 

DX, DX 


ADD 

AX.DX 


ADD 

AX, DX 


SUB 

AX.DX 


SUB 

AX ,DX 


CLC 



CLD 



NOP 



NOP 


ENDM 



; End of test code 


LOOP 

RET 

SINNER 

SINNER: 

JMP 

INNER 


DBB16 ENDP 


CODE ENDS 
END 


LPI.BAT 

"IBM PC Accelerators," by Stephen S. Fried. Inside 
the IBM PCs, Extra Edition, page 140. 


LINK PI DBB4 DBB16 DBBCACHE CB4 CB16 IA XFER TIME100.PI; 


DBBCACHE.ASM 

"IBM PC Accelerators," by Stephen S. Fried. Inside 
the IBM PCs, Extra Edition, page 140. 


NAME DBBCACHE 

; Data bus bound — 4K bytes of register bound 

; Assembly language subroutine source for PI program. 
; Provided to Byte Magazine by: 

; MicroWay, Inc. 

; PO Box 79 
; Kingston MA 02364 

; (617) 746-7341 

; Copyright (C) MicroWay, Inc., 1986. 

PUBLIC DBBCACHE 


[continued) 
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DGROUP GROUP COMMON 


COMMON SEGMENT PARA COMMON ‘BLANK* 


_DSRC 

DW 

10240 DUP (?) 

_DDEST 

DW 

10240 DUP (?) 

SPC$1_ 

DD 

1.0 

SPC$2_ 

DD 

2.0 

SPC$3_ 

DD 

3.0 

SV$A 

DD 

0.0 

SV$B 

DD 

? 

COMMON 

ENDS 


CODE 

SEGMENT 

WORD PUBLIC ’CODE’ 

ASSUME 

CS:CODE 

, DS:DGROUP 

DBBCACHE 

PROC FAR 


MOV 

CX,161 

INNER: 



; Start 

of test 

code 

REPT 

256 * 8 



MOV 

AX.BX ; 2 clocks, 2 bytes; shows 80286 cache board 



; to advantage. 

ENDM 



; End of test code 


LOOP 

$INNER 


RET 


$INNER: 

JMP 

INNER 

DBBCACHE 

ENDP 

CODE 

ENDS 



END 



CB4.ASM 

M IBM PC 
the IBM 

Accelerators," by Stephen S. Fried. Inside 

PCs, Extra Edition, page 140. 

/ 

NAME 

CB4 



; Clock 

bound — 

- 4K byte block moves 


; Assembly language subroutine source for PI program. 


; Provided to Byte Magazine by: 


; MicroWay, Inc. 



; PO Box 79 



; Kingston MA 02364 


; (617) 746-7341 


; Copyr 

ight (C) MicroWay. Inc., 1986. 


PUBLIC 

CB4 



DGROUP 

GROUP 

COMMON 


COMMON 

SEGMENT 

PARA COMMON * BLANK * 


_DSRC 

DW 

10240 DUP (?) 


_DDEST 

DW 

10240 DUP (?) 


SPC$1_ 

DD 

1 .0 


SPC$2_ 

DD 

2.0 


SPC$3_ 

DD 

3.0 


SV$A 

DD 

0.0 


SV$B 

DD 

? 
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COMMON 

ENDS 


CODE 

SEGMENT 

WORD PUBLIC ‘CODE’ 

ASSUME 

CS:CODE, 

, DS:DGROUP 

CB4 

PROC 

FAR 

INNER: 

MOV 

CX,38 

; Start 

of test 

code 


PUSH 

CX 


MOV 

SI,OFFSET DGROUP:_DSRC 


MOV 

DI,OFFSET DGROUP:_DDEST 


MOV 

CX,4096 


REP 

MOVSB 


POP 

CX 


; End of test code 



LOOP 

RET 

SINNER 

$INNER: 

JMP 

INNER 

CB4 

ENDP 


CODE 

ENDS 



END 



CB16.ASM 

"IBM PC Accelerators," by Stephen S. Fried. Inside 
the IBM PCs, Extra Edition, page 140. 


NAME CB16 

; Clock bound — 16K byte block moves 

; Assembly language subroutine source for PI program. 
; Provided to Byte Magazine by: 

; MicroWay, Inc. 

; PO Box 79 
; Kingston MA 02364 

; (617) 746-7341 

; Copyright (C) MicroWay, Inc., 1986. 


PUBLIC 

CB16 


DGROUP 

GROUP 

COMMON 

COMMON 

SEGMENT 

PARA COMMON * 

_DSRC 

DW 

10240 DUP (?) 

_DDEST 

DW 

10240 DUP (?) 

SPC$1_ 

DD 

1.0 

SPC$2_ 

DD 

2.0 

SPC$3_ 

DD 

3.0 

SV$A 

DD 

0.0 

SV$B 

DD 

? 

COMMON 

ENDS 


CODE 

SEGMENT 

WORD PUBLIC • 

ASSUME 

CS:CODE 

, DS:DGROUP 

CB16 

PROC 

FAR 


BLANK• 


CODE* 


[continued) 
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MOV 

CX, 10 

INNER: 


; Start of test code 

PUSH 

CX 

MOV 

SI.OFFSET DGROUP:_DSRC 

MOV 

01,OFFSET DGROUP:_DDEST 

MOV 

CX,16384 

REP 

MOVSB 

POP 

CX 

; End of test 

code 

LOOP 

RET 

SINNER 

SINNER: JMP 

INNER 

CB16 ENDP 


CODE ENDS 


END 


IA.ASM 


"IBM PC Accelerators," by Stephen S. Fried. Inside 

the IBM PCs, 

Extra Edition, page 140. 


NAME IA 


; Integer multiply and divide 

; Assembly language subroutine source for PI program. 
; Provided to Byte Magazine by: 

; MicroWay, Inc. 

; PO Box 79 
; Kingston MA 02364 

; (617) 746-7341 

; Copyright (C) MicroWay, Inc., 1986. 


PUBLIC 

IA 


DGROUP 

GROUP 

COMMON 

COMMON 

SEGMENT 

PARA COMMON '1 

_DSRC 

DW 

10240 DUP (?) 

_DDEST 

DW 

10240 DUP (?) 

SPC$1_ 

DD 

1 .0 

SPC$2_ 

DD 

2.0 

SPC$3_ 

DD 

3.0 

SV$A 

DD 

0.0 

SV$B 

DD 

? 

COMMON 

ENDS 


CODE 

SEGMENT 

WORD PUBLIC 1 

ASSUME 

CS:CODE 

, DS:DGROUP 

IA 

PROC 

FAR 

INNER: 

MOV 

CX,922 

; Start 

of test 

code 


MOV 

AX, 89 


MOV 

BX.73 

REPT 

10 



IMUL 

BX 


IDIV 

BX 
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ENDM 


; End 

of test 

code 


LOOP 

RET 

SINNER 

SINNER 

: JMP 

INNER 

IA 

ENDP 


CODE 

ENDS 



END 



XFER.ASM 

"IBM PC Accelerators," by Stephen S. Fried. Inside 
the IBM PCs, Extra Edition, page 140. 


NAME XFER 

; Subroutine calls and stack operations 

; Assembly language subroutine source for PI program. 
; Provided to Byte Magazine by: 

; MicroWay, Inc. 

; PO Box 79 
; Kingston MA 02364 

; (617) 746-7341 

; Copyright (C) MicroWay, Inc., 1986. 


PUBLIC 

XFER 


DGROUP 

GROUP 

COMMON 

COMMON 

SEGMENT 

PARA COMMON *1 

_DSRC 

DW 

10240 DUP (?) 

_DDEST 

DW 

10240 DUP (?) 

SPC$1_ 

DD 

1.0 

SPC$2_ 

DD 

2.0 

SPC$3_ 

DD 

3.0 

SV$A 

DD 

0.0 

SV$B 

DD 

? 

COMMON 

ENDS 


CODE 

SEGMENT 

WORD PUBLIC *1 

ASSUME 

CS:CODE 

, DS:DGROUP 

FP 

PROC 

FAR 


PUSH 

AX 


POP 

AX 


RET 


FP 

ENDP 


XFER 

PROC 

FAR 


MOV 

CX.4105 

INNER: 



; Start 

of test 

code 


CALL 

NP 


CALL 

NP 


CALL 

NP 


CALL 

NP 


CALL 

NP 


CALL 

FP 


(continued) 
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; End of test code 



LOOP 

RET 

SINNER 

SINNER: 

JMP 

INNER 

XFER 

ENDP 


NP 

PROC 

NEAR 


PUSH 

AX 


PUSH 

BX 


POP 

BX 


POP 

AX 


RET 


NP 

ENDP 


CODE 

ENDS 



END 



LISTING!.TXT 

"C Versus Assembly — C Plus Assembly," by Tom Hogon. 
Inside the IBM PCs, Extra Edition, page 267. 


PUSH_REGS MACRO REG!, REG2, REG3, REG4 
NUM.REGS = 1 
PUSH REG! 

IFNB <REG2> 

NUM.REGS « NUM_REGS + 1 

PUSH REG2 

ENDIF 

IFNB <REG3> 

NUM_REGS * NUM REGS + 1 

PUSH REG3 

ENDIF 

IFNB <REG4> 

NUM_REGS = NUM REGS + 1 

PUSH REG4 

ENDIF 

PUSH BP 

MOV BP, SP 

ARG_BASE EQU BP + 4 + (2 * NUMJREGS) 
ENDM 


LISTING2.TXT 

"C Versus Assembly — C Plus Assembly," by Tom Hogan. 
Inside the IBM PCs, Extra Edition, page 267. 


POP_REGS MACRO REG!, REG2, REG3, REG4 

POP BP 

IFNB <REG4> 

POP REG4 
ENDIF 
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IFNB <REG3> 
POP REG3 
ENDIF 

IFNB <REG2> 
POP REG2 
ENDIF 

POP REG1 

ENDM 


LISTING3.TXT 

"C Versus Assembly — C Plus Assembly," by Tom Hogan. 
Inside the IBM PCs, Extra Edition, page 267. 


MOV 

AX, VARIABLE 

3 bytes 

, 14 clocks 


MOV 

CL, 4 

2 bytes 

, 4 clocks 


SHL 

AX, CL 

2 bytes 

, 24 clocks 


MOV 

BX, AX 

2 bytes 

, 2 clocks 


SHL 

AX, 1 

2 bytes 

, 2 clocks 


SHL 

AX, 1 

2 bytes 

, 6 clocks - 

- prefetch queue 



is empty before the 

instruction 



is executed 


ADD 

> 

X 

CD 

X 

2 bytes 

, 14 clocks 

— 4 clocks/byte 



for the 

BIU to put 

the instruction 



in the 

queue plus 2 

clocks to 



execute 

it 



LISTING4.TXT 

"C Versus Assembly — C Plus Assembly," by Tom Hogan. 
Inside the IBM PCs, Extra Edition, page 267. 


MOV CX, 40 

MOV 01, BUFFER 

MOV SI, SCREEN_OFFSET 

START: 

MOV AX. [DI] 

AND AX, 07F7FH 
MOV [SI], AX 
ADD SI, 2 
ADD DI, 2 
LOOP START 


40 WORDs to search 

DI points at the buffer 

SI points at the screen offset 


14 clocks — get two chars from the buffer 

4 clocks — turn off the high bits 

14 clocks — put the chars into screen ram 

4 clocks — the next two chars in the buffer 

4 clocks — the next two chars in screen ram 

17 clocks — continue until CX is zero 


LISTING5.TXT 

"C Versus Assembly — C Plus Assembly," by Tom Hogan. 
Inside the IBM PCs, Extra Edition, page 267. 


MOV 

CX, 

128 

MOV 

AL, 

VALUE 

MOV 

REPNZ SCASB 

DI, 

OFFSET 


SEARCH 128 BYTES 
VALUE TO BE FOUND 
START OF MEMORY TO SEARCH 
15 clocks/repetition, 
plus 2 clocks per 
execution of prefix. 
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LISTING6.TXT 

"C Versus Assembly — C Plus Assembly," by Tom Hogan. 
Inside the IBM PCs, Extra Edition, page 267. 


MOV 

cx, 

128 

SEARCH 128 BYTES 

MOV 

AL, 

VALUE 

VALUE TO BE FOUND 

MOV 

AH, 

AL 

SAME VALUE IN AH 

MOV 

DI. 

OFFSET 

START OF MEMORY TO SEARCH 

DEC 

DI 



INC 

DI 


2 clocks 

MOV 

AL, 

AH 

2 clocks 

SUB 

AL. 

[Dll 

14 clocks 

LOOPNZ TOP 

19 clocks 


LISTINGS1.DOC 

"Memory Manipulations," by Alan R. Miller. Inside 
the IBM PCs, Extra Edition, page 232. 


\foot4 

\ctr\- \%page\ - 

\right 

605056-1 

\left 

\ I m0 

\rm80 

\sp1 

\hy 

\un 

\bf 

\ssa 

\ssb 

Listing 1. 


@d_char MACRO par? 

;; display par? on video screen 

;; Usage: @d_char AL ;;from register 

;; @d_char ;;constant 


PUSH 

DX 

MOV 

DL.par? 

MOV 

AH. 2 

INT 

21h 

POP 

DX 

ENDM 


@ucase MACRO 


LOCAL 

notup? 

;; Macro to change AL to 

;; Usage: @ucase 

CMP 

AL,'a' 

JB 

notup? 

AND 

AL,5Fh 


notup? 


upper case 

;;upper case? 

; ;yes 

;;make upper 

date’ 

;;wr1te string 


ENDM 

@write MACRO text? 

LOCAL around,mesg 
;; Macro to embed version number 


IS 

@wrIte 'title 

PUSH 

DX 

PUSH 

AX 

MOV 

AH, 9 

MOV 

DX,OFFSET mesg 

INT 

21h 

POP 

AX 

POP 

DX 

JMP 

SHORT around 
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mesg DB text?,'$’ 

around: ;;write 

ENDM 

@write_r MACRO addr? 

;; display text at location addr? 

;; text must end with $ 

;; Usage: @write_r cOFFSET p_ver> 

PUSH DX 

MOV DX,addr? 

MOV AH,9 

INT 21h 

POP DX 

ENDM 

\np 

\foot4 

\ctr\- \%page\ - 

\right 

605056-2 

\left 

\ I m0 

\rm80 

\sp1 

\hy 

\un 

\bf 

\ssa 

\ssb 

Listing 1. 


PAGE ,132 

TITLE FILL part of memory 
COMMENT * 

Program to fill part of memory with 
resident program (some programs will 
not run when there is too much memory. 
Macros: ©write 
INT 27h 

* 

cr EQU 13 

If EQU 10 

IF 1 

INCLUDE mymac.lib 
ENDIF 

code SEGMENT 

ASSUME CS:code, DS:code 

ORG 100h 


©write <cr,lf,* Memory reduced 64K bytes*> 


» 

: quit 

and stay 

resident 


• 

MOV 

DX,OFFSET 

strt-OFFSET 


INT 

27h 

;done 

pg_1en 

LABEL 

BYTE 


code 

ENDS 




END 

strt 
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ADUMP.ASM 

"Memory Manipulations," by Alan R. Miller. Inside the 
IBM PCs, Extra Edition, page 232. 


PAGE .132 
TITLE ADUMP 

COMMENT * 

May 18, 1968 

Display a portion of memory In hex and ASCII 
Successive hex bytes are reversed In Arabic fashion 
Usage: 



ADUMP 




ADUMP 

400 

offset 


ADUMP 

5300 0 ; 

segment, offet 

Macros: ®d_char, Oucase 

i, @write_r 

INT : 

21 h funct 

ion 8 


♦ 

ENDIF 



b 1 ank 

EQU 

32 


cr 

EQU 

13 


esc 

EQU 

IBh 


If 

EQU 

10 


period 

EQU 

46 


up_arr 

EQU 

72 

;up cursor 

down_ar EQU 

80 

;down cursor 

P9- U P 

EQU 

73 

;previous scr< 

pg_dn 

EQU 

81 

;next screen 

code 

SEGMENT 



ASSUME 

CSicode, 

DS:code 


ORG 

5Dh 


paraml 

DB 

? 

;parameter 1 


ORG 

6Dh 


param2 

DB 

? 

;parameter 2 


ORG 

100h 


strt: 





@write_ 

.r cOFFSET 

mes1> 

; set 

segment and offset 

to zero 


XOR 

SI,SI 

;zero offset 


MOV 

ES .SI 

; segment 


; check if parameter was entered 
MOV DI,OFFSET paraml 

CMP BYTE PTR [DI],blank ;anything? 

JZ t_lines 

; convert parameter from ASCII hex to binary in SI 
CALL get_hex 

MOV SI,DX 

; check if second parameter was entered 
MOV DI,OFFSET param2 

CMP BYTE PTR [DI],blank ;anything? 

JZ t_lines 

MOV ES,SI 

; convert parameter from ASCII hex to binary in SI 
CALL get_hex 

MOV SI,DX 


start display of 16 lines 
ES has segment, SI has offset 


t_lInes: 

@wrlte_r cOFFSET mes2> 

MOV CX,21 ;Iines 

n_line: 

@d_char cr 
@d_char If 

; display address and 16 hex bytes 
CALL do_hex 
; display ASCII 

CALL do_asciI 
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w a i t 


ADD SI,16 

LOOP n_line 

for keyboard input 


;next line 


CALL 

get_in 



CMP 

AL.esc 


;quit? 

JZ 

done 


;yes 

CMP 

AL.cr 


;next page? 

JNZ 

not_cr 


;no 

JMP 

t_lines 



CMP 

AL,pg_dn 



JNZ 

not_pd 



JMP 

t_lines 


;next page 

CMP 

AL,up_arr 



JNZ 

not_.ua 


;prev line 

up pointer one 1Ine 

and 

red!sp1 ay 

SUB 

SI,22*16 



JMP 

t_lines 



CMP 

AL.pg_.up 



JNZ 

not_t1 


;prev page 

up pointer one page 

and 

redisp1 ay 

SUB 

SI,42*16 



JMP 

t_lines 



MOV 

CX,1 



CMP 

AL,b1ank 



JZ 

n_line 


;next 1ine 

CMP 

AL,down_ar 



JZ 

n_line 


;next 1ine 

INT 

20h 




not_cr: 


not_pd: 


not_ua: 


not_tI 


done: 


; translation table binary to ASCII hex 
hex_tab DB *0123456789ABCDEF’ 

;****************************************** 
; Convert binary number in AL to hex and 
and display on screen 


Input: 


AL * byte 


;****************************************** 


outhex 

PROC 

PUSH 

DX 



MOV 

DL.AL 

;save 


REPT 

SHR 

ENDM 

4 

AL, 1 

;times 16 


CALL 

outhx 

;high half 


MOV 

AL.DL 

;get back 


CALL 

outhx 

;1ow half 

outhex 

MOV 

POP 

RET 

ENDP 

AL.DL 

DX 

;restore 


;******** End outhex ******************* 
;***************************************** 

; convert four bits in AL to hex and 
; display on screen 

;***************************************** 
outhx PROC 

AND AL,0Fh ;low4bits 

PUSH BX 

MOV BX.OFFSET hex_tab 

XLAT hex_tab 


@d_char AL 


outhx 


POP 

RET 

ENDP 


BX 


;dispI ay 


;******** End outhx ******************** 
;***************************************** 
; Convert ASCII hex to binary 

; Input: DI points to string 

; Output: DX - binary value 

;***************************************** 
get_hex PROC 

PUSH AX 


IBK 


S 


[continued) 
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XOR 

AX, AX 


MOV 

DX, AX 

g_hex2: 




MOV 

AL,[DI] 


SUB 

AL.'0' 


JL 

9 _hex_b 


CMP 

AL, 10 


JL 

g_hex_g 


@ucase 



SUB 

AL, *A*- , 9 ,< 


JL 

g_hex_b 


CMP 

AL, 15 


JG 

g_hex_b 

; add new character to sum 

g_hex_g: 




REPT 

4 


SHL 

DX, 1 


ENDM 



ADD 

DX, AX 


INC 

DI 


JMP 

g_hex2 

; end of 

string 

g_hex_b: 




POP 

AX 


RET 


get_hex 

ENDP 


;************* 

End of get. 


; zero 
;DX too 


;moke binary 
;too low 

;ok 

;make upper 
;adjust for A-F 
;too low 

;too large 


;next char 


; display address and 16 hex bytes 
; Input: SI • pointer 

; Output: SI is 16 larger 

I ****************************************** 

do_hex PROC 

DI.SI 
DI, 16 
CX 

CX.16 


MOV 
ADD 
PUSH 
MOV 

next_ch: 

DEC 
MOV 
CALL 
PUSH 
MOV 

; put a minus 
MOV 
AND 
JZ 
AND 
JNZ 
MOV 

not_min: 

@d__char 
POP 
LOOP 
POP 
d_char 


DI 

AL,ES:[DI] 
outhex 
BX 

BL, b Iank 

sign at quarter points 
AX, DI 
AL,0fh 
not_min 
AL, 3 
not_min 
BL,’-' 


;one Iine 
;next 


line end 


;minus 


BL 
BX 

next_ch 
CX 

b I ank 

display address at right side 
PUSH BX 

display segment address 


do_hex 


MOV 

BX.ES 


MOV 

AL.BH 


CALL 

outhex 

;high half 

MOV 

AL, BL 

CALL 

outhex 

;low half 

@d_char 

*.» 

;co1 on 

ay offset address 


MOV 

BX.SI 

;offset 

MOV 

AL.BH 


CALL 

outhex 

;high half 

MOV 

AL.BL 

POP 

BX 


CALL 

RET 

ENDP 

outhex 

;1ow half 
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************* End of do_hex ************ 
****************************************** 
display 16 ASCII bytes 
control characters shown as period 
extended character translated to ASCII 


Input: 


SI = pointer 


****************************************** 

do_ascii 

PROC 




@d_char 

blank 



@d_char 

blank 



MOV 

DI.SI 



PUSH 

CX 



MOV 

CX, 16 

;one 1ine 

next_as: 





MOV 

AL,ES:[DI] 



AND 

AL,7Fh 

;make ASCII 


CMP 

AL,7Fh 

;DEL? 


JZ 

d_per 

;yes 


CMP 

AL,blank 

;too sma11? 


JNB 

nbl 


d_per: 




; change 

to period 



MOV 

AL.period 


nbl : 





@d_char 

AL 



INC 

DI 

;next 


LOOP 

next_as 



POP 

CX 



RET 



do_ascii 

ENDP 



; ************* 

End of do_asci 

I ********** 

;****************************************** 

; wait for character from keyboard 

; don't 

echo on 

screen 


; if extended code, two calls 

are made 

» 

; Output 

; 

AL * character 


; ****************************************** 

get_in 

PROC 




MOV 

AH,8 



INT 

21 h 



OR 

AL, AL 

;zero? 


JNZ 

get_2 

; no 

: get extended 

code 



INT 

21 h 


get_2: 





RET 



get_in 

ENDP 



• ************* 

End of get_in 

********** 

mes 1 

DB 

* Arabic di 

isplay—Hex goes fi 


DB 

' right to left*.cr,If 


DB 

• Active keys 

are: down and up* 


DB 

* arrows. PgDn, PgUp, and Esc$’ 

mes2 

DB 

cr.lf.lf,* F 

E D C 8 A 9 


DB 

' 7 6 5 A 

3 2 10 SEGM 


DB 

• ADDR 0123456789ABCDEF $’ 

code 

ENDS 




END 

strt 



8 ’ 


MYMAC.LIB 

"Memory Manipulations," by Alan R. Miller. Inside 
the IBM PCs, Extra Edition, page 232. 


®d_char MACRO par? 

;; display par? on video screen 
;; Usage: ©d_char AL ;;from register 

;; ®d_char '*' ;;constant 

PUSH DX 

MOV DL,par? 

( continued ) 
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MOV 

AH,2 


INT 

21 h 


POP 

DX 


ENOM 



©ucase MACRO 



LOCAL 

notup? 


;; Macro to change AL to upper case 


;; Usage: ©ucase 


CMP 

AL,; ;upper case? 


JB 

notup? ;;yes 


AND 

AL,5Fh ;;make upper 


notup?: 



ENDM 



©write MACRO 

text? 


LOCAL 

around,mesg 


;; Macro to embed version number 


;; Usage: 

©write 'title, date’ 


PUSH 

DX 


PUSH 

AX 


MOV 

AH,9 ;;write string 


MOV 

DX.OFFSET mesg 


INT 

21h 


POP 

AX 


POP 

DX 


JMP 

SHORT around 


mesg DB 

text?,*$’ 


around: 

;;wrIte 


ENDM 



©write_r MACRO 

addr? 


;; display text at location addr? 


;; text must end with $ 


;; Usage: @write_r <OFFSET p_ver> 


PUSH 

DX 


MOV 

DX,addr? 


MOV 

AH,9 


INT 

21h 


POP 

DX 


ENDM 



FILL.ASM 



"Memory Manipul 

otlons," by Alan R. Miller. Inside the 


IBM PCs, Extra 

Edition, page 232. 


PAGE 

,132 


TITLE 

FILL part of memory 



COMMENT * 

Program to fill part of memory with 
resident program (some programs will 
not run when there is too much memory). 
Macros: ©write 
INT 27h 

* 

cr EQU 13 

If EQU 10 

IF 1 

INCLUDE mymac.lib 
ENDIF 

code SEGMENT 

ASSUME CS:code, DS:code 

ORG 100h 

strt: 

©write <cr, I f , * Memory reduced 64K bytes’> 


quit and stay resident 
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MOV 

DX,OFFSET 

strt-OFFSET pg_len 


I NT 

27h 

; done 

og_len 

LABEL 

BYTE 


code 

ENDS 

END 

strt 



MEM704.ASM 

"Memory Manipulations," by Alan R. Miller. Inside 
the IBM PCs, Extra Edition, page 232. 


PAGE ,132 

TITLE 704K - set memory to 704K bytes 
COMMENT * 

Increase memory to 704K bytes by changing 
BIOS data word at 40:13 hex 
Set new memory to zero 


February 23, 

1986 


cr 

EQU 

13 


If 

EQU 

10 



IF 1 




INCLUDE 

mymac.lib 



ENDIF 



o1d_siz 

EQU 

640 

;o1d mem size 

new_siz 

EQU 

704 

;new mem size 

new.seg 

EQU 

0A000h 

;704K segment 

; BIOS data area 


bios_d 

SEGMENT 

AT 40h 



ORG 

13h 


mem_siz 

LABEL 

WORD 

;memory size 

bios_d 

ENDS 



code 

SEGMENT 




ASSUME 

CS:code,DS: 

code, ES:bios_d 


ORG 

100h 


strt: 




; point 

to memory size in BIOS data area 


MOV 

AX,bios_d 

; z e r o 


MOV 

ES, AX 



MOV 

SI,OFFSET mem_siz 

; check 

if already run 



CMP 

WORD PTR ES:[SI],new_siz 


JNE 

ok 



I NT 

20h 

;qu i t 

; check 

for memory at A000 

hex 

ok: 





MOV 

BX, ES 

;save ES 


MOV 

AX,new_seg 



MOV 

ES, AX 

;ES-A000 


XOR 

DI,DI 

; o f f s e t 


MOV 

AX,55AAh 

101010101 


MOV 

ES:[DI],AH 

;55 hex 


CMP 

AH,ES:[DI] 

;ok? 


JNZ 

no_mem 

;no 


MOV 

ES:[DI1.AL 

;AA hex 


CMP 

AL,ES:[DI] 

;ok? 


JNZ 

no_mem 

; no 

; set memory size for 704K 

bytes 


MOV 

CX, ES 

;save ES 


MOV 

ES.BX 

;ES-40 


MOV 

WORD PTR ES:[SI],new_siz 


MOV 

ES.CX 

;ES«A000 

; fill 

new memory with zeros 


XOR 

AX, AX 

;zero word 


MOV 

DI, AX 

;zero location 


MOV 

CX,8000h 

;32K words 


REP 

STOSW 

;do It 


( continued ) 
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@wrIte 
INT 

; no memory at 
no_mem: 

@wrIte 
INT 


<’ Memory now 704K bytes 1 ,cr,If> 
‘•Qh jreboot system 

A000 hex, terminate without change 

* No memory at A000 hex, aborting* 
20h 


x code ENDS 

END strt 


LISTINGS2.DOC 

"Memory Manipulations," by Alan R. Miller. Inside the 
IBM PCs, Extra Edition, page 232. 


PAGE ,132 

TITLE 704K - set memory to 704K bytes 
COMMENT * 7 

Increase memory to 704K bytes by changing 
BIOS data word at 40:13 hex 


Set 

new memory to zero 



February 23, 

* 

1986 



cr 

EQU 

13 



If 

EQU 

10 




IF1 





INCLUDE 

mymac.lib 




ENDIF 




o1d_siz 

EQU 

640 


;o1d mem size 

new_siz 

EQU 

704 


;new mem size 

new_seg 

EQU 

0A000h 


;704K segment 

; BIOS 

data area 



bios_d 

SEGMENT 

AT 40h 




ORG 

13h 



mem_siz 

LABEL 

WORD 


;memory size 

blos_d 

ENDS 




code 

SEGMENT 





ASSUME 

CS:code,DS 

: code, 

ES:bios_d 


ORG 

100h 



strt: 





; point 

to memory size in 1 

BIOS data area 


MOV 

AX,bios d 


; zero 


MOV 

ES, AX 




MOV 

SI,OFFSET i 

mem_siz 

; check 

if already run 




CMP 

WORD PTR ES:[SI 1 

,new_siz 


JNE 

ok 




INT 

20h 


; qu i t 

; check 

for memory at A000 

hex 


ok: 






MOV 

BX.ES 


;save ES 


MOV 

AX,new seg 




MOV 

ES, AX 


;ES=A000 


XOR 

DIjDX 


;of fset 


MOV 

AX,55AAh 


;01010101 


MOV 

ES:[DI],AH 


;55 hex 


CMP 

AH,ES:[DI] 


;ok? 


JNZ 

no_mem 


;no 


MOV 

ES:[Dll,AL 


;AA hex 


CMP 

AL.ES:[DI] 


;ok? 


JNZ 

no_mem 


; no 


; set memory size for 704K bytes 

MOV CX.ES ;save ES 

MOV ES.BX ;ES=40 

MOV WORD PTR ES:[SI],new_siz 
MOV ES,CX ;ES=A000 

; fill new memory with zeros 

XOR AX,AX ;zero word 

MOV DI.AX ;zero location 
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MOV CX,8000h 

REP STOSW 


;32K words 
; do it 


©write <’ Memory now 704K bytes *,cr,If> 
INT 19h ;reboot system 

; no memory at A000 hex, terminate without change 
no_mem: 

©write 'No memory at A000 hex, aborting’ 

INT 20h 

code ENDS 

END strt 


\np 


PERPROPC.ASM 

"Performance Programming," by Joel Rosenblum and Dan 
Jacobs. Inside the IBM PCs. Extra Edition, page 181. 

; Cputest.asm is the Lattice C-callable assembly language routine that determines 
; the machine’s processor type. 

; Copyright (c) 1986 Dan Jacobs and Joel Rosenblum 
name cputest ‘.determine CPU type 


; Lattice C memory model configuration macro 
; In this case it is a copy of dm8086.mac 


include dos.mac 


; processor type equates 


Intel 8088 - 8086 
Intel 80188 - 80186 
Intel 80286 
NEC V20 - V30 


CPU_88 equ 01H 
CPU_186 equ 02H 
CPU_286 equ 04H 
CPU_V20 equ 08H 


PSEG 

comment\**********♦********♦♦******♦*********♦*************** 1, ' , * c * , *'*** , * , *** ,,t, * ,,,t * ,,c,,, 

NAME 

cputest 

SYNOPSIS 

unsigned int cputest (features) 

unsigned Int features; see definition of machine type 

DESCRIPTION 

returns features with the proper active CPU type or’ed in 
******************* 



cputest 

near 


pub Iic 


cputest 


proc 


; save the frame pointer (if called from C) 


BP 

BP, SP 


push 

mov 


; next, save the passed existing features 

mov AX, 4[BP] 

push AX 

; check for 8088 or 8086 by using the SHR instruction since the 
; 8088 and 8086 do not mask cl with 07H before executing the shift. 

mov CL, 20H 

mov AX, 1 

shr AX, CL 


(continued) 
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test AX, AX ; if after the shift AX is the same 

; as before, it’s a 8088 - 8086 or V20 - V30 
jnz check_80186 ; else, continue checking other Intel CPUs 

; check for V20 or V30 by detecting if PUSHA is a valid instruction 
s on the NEC CPUs 



mov 

pusha 

BX. 

SP 


cmp 

X 

CD 

SP 


J* 

popa 

i s_88 


mov 

AX, 

CPU. 


Jmp 

return 

is_88: 

mov 

AX, 

CPU. 

check_80186: 

Jmp 

return 


; save SP 

; if SP has not been decremented, then 
; it’s an 8088 - 8086 
; else, we restore registers 


; check for the 80188 or 80186 by detecting if SP is updated 
; before or after it is pushed. 



push 

pop 

cmp 

SP 

BX 

BX, SP 



je 

is_286 

; if updated after, it's a 80286 


mov 

jmp 

AX, CPU.186 
short return 

; else, it's a 80186 or 80188 

is_286: 

mov 

AX, CPU_286 


return: 

pop 

BX 

; recall saved features 

cputest 

or 

pop 

ret 

endp 

ENDPS 

end 

AX, BX 

BP 

; and or cputype into other features bits 

title 

LISTING 

4 ;DETECTING 

MATH CO-PROCESSOR 


; testndp.asm is the Lattice C-callable assembly language routine that 
; determines the presence of an 8087 or 80287 math co-processer chip. 

; assembeIed using Microsoft MASM v4.0 

; Copyright (c) 1986 Dan Jacobs and Joel Rosenblum 

; portions copyrighted by MicroWay, Inc. 

name test_ndp 

include dos.mac ; Lattice C memory model configuration macro 

; In this case it is a copy of dm8086.mac 

» have to code the instructions for the NDP as dbs as the assembler 
; generates an unwanted WAIT instruction 


FINIT_MAC 

MACRO 



db 

ENDM 

0DBH, 0E3H 

FSTCW_MAC 

MACRO 

address 


db 

0D9H, 03EH 


dw 

ENDM 

offset DGROUP:address 


; bit mask for coprocessor in FEATURES 

NDP 0010H ; a coprocessor is present 
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ndp word dw 0 ; a storage location for the ndp to use for test 

ENDDS 

PSEG 


comment\********************************************************************** 

NAME 

testndp 


SYNOPSIS 


Check to see if a 8087 or 80287 numeric data processor is 
present in the machine. Here, we present two methods which 
you may select based upon how you set CHOOSE in the code: 
First, IBM’s recommended procedure which does an int 11 
(equipment determination) BIOS call. The problem with this 
method is that it only works on IBMs and 100% compatibles. 
Note that in the PC and XT the returned value is determined 
by reading the switch setting. Unfortunately, all of the 
early "guide to operations" manuals informed you to set the 
switch the coprocessor the wrong way, rendering it usless. 
Second, MicroWay’s recommended procedure checks for the 
coprocessor directly. We believe that this method should be 
used since it is more universal. We leave the choice to you 
depending how you set the equ for CHOOSE below: 


1 to use int 11 
or 

0 for direct check 


SYNOPSIS 


unsigned int test_ndp 
unsigned features; 


(features); 

see definition of machine type 


RETURN VALUE 


the passed features variable with the NDP bit or’ed in 
*****************************************************************************\ 


CHOOSE equ 


test_ndp 


0 ; 0 ■ direct ndp check, 1 - IBM Int 11 bios call 

pub Iic test_ndp 
proc near 


assume ds:DGROUP 

push bp 

mov bp, sp 


save the frame pointer (if called from C) 


; next, save the passed existing features 
mov ax, 4[bp] 

push ax 


if CHOOSE ; use bios int check 

int 11H 

and ax, 2 ; 

jz no_ndp 

else ; use direct ndp check ala MicroWay 
FINITJMC 

mov ndp_word, 0 

FSTCW_MAC <ndp_word> 


II: 


mov 

cx, 064H 


push 

dx 


pop 

dx 


loop 

11 


and 

ndp_word, 

03BFH 

cmp 

ndp_word, 

03BFH 

jne 

no_ndp 



equipment determination call 
coprocessor present 


initilize the coprocessor 
fstcw ndp_word 

move control word to ndp_word 
count for wait loop 


mask to bits we want 
alI the correct bits set 


mov ndp_word, 0 

FSTCWJMC <ndp_word> ; fstcw ndp_word 


( continued ) 
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12: 

mov 

push 

pop 

loop 

and 

cmp 

jne 

cx, 064H 

dx 

dx 

12 

ndp_word, 1F3FH 
ndp_word, 033FH 
no_ndp 

; move control word to ndp word 
; count for wait loop 

; mask to bits we want 
; all the correct bits set 

end 1 f 

mov 

jmp 

bx, NDP 
short ndp_ex1t 

; mask to turn on coprocessor bit 

no_ndp: 

mov 

bx, 0 

; nothing to mask in 

ndp_ex 1 t: 




pop 

or 

X 

X X 

o o 

; get saved passed features 
; and or in bit for ndp 


pop 

bp 

; restore frame pointer to return to C caller 


ret 



test_ndp 

endp 



ENDPS 

end 




title Listing 5o ;Colculoting Timing Loops 


Co .asm Is on assembly language routine that provides 
delay Independent of clock speed. It may be called 
routine in your software as illustrated in listing 5b 


a standard 
from a C 


! Note: The PC’s timer Interrupt is assumed set to the standard ~18.2Hz 
; Copyright (c) 1986 Howie Marshall, Applied Reasoning Corp. 


pgroup group 

prog 


dgroup group 

data 


bios_data 

segment 

at 40H 


org 

06cH 

1ow_t1 me 

dw 

? 

bios_data 

ends 


data 

segment 

public * data * 

dummy 

data 

extrn 

us500:word, ms2:word 

dw 

ends 

® J a dummy to compare against 


prog segment byte public 'prog* 

» 

; delaycal - calibrate the delay loop 
> 

j temp - delaycal(delay_time) from C. Returns delay_count 


assume 
pub Iic 

delaycal proc 
assume 
push 
push 
mov 
mov 
mov 
assume 


cs: pgroup 
deIaycaI 
near 

ds:dgroup 

bp 

ds 

bp.sp 

ax,bios_data 
ds ,ax 

ds:bios_data 


wait for the timer to tick over 


mov dl,low_time 

timwait: 

cmp d i, Iow_time 

j e timwait 
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xor 

ax, ax 


xor 

dx, dx 


add 

di ,6 

; wait for 5 more ticks 

************************************************************* 

imloop: 

add 

ax, 1 


adc 

dx ,0 

; have 5 ticks occurred yet? 

cmp 

di,1ow_time 

ja 

timloop 

; no, continue looping 


************************************************************* 


5 ticks @ 18.2 ticks/sec «> 270272 microseconds in 5 ticks 


270272 « 16 * 16892 


mov 

bx, 16 


di v 

bx 

; cut down to single word 

mov 

bx,6[bp] 

; get desired delay time 

mu 1 

bx 


mov 

bx,16892 


d I v 

bx 

; finish divide-by-270272 

or 

ax ,ax 


jnz 

t imok 


i nc 

ax 

; do at least one loop 

mov 

sp.bp 


pop 

ds 


assume 

ds:dgroup 


pop 

bp 


ret 




delaycol endp 
i DELAY SUBROUTINES: 


This routine delays for 500 microseconds. 


pub Iic 

del500u proc 

assume 

mov 

neg 


deI500u 
near 

ds:dgroup 

ax,us500 

ax 


This loop contains the same instructions as the calibration loop 
in delaycal above, but in a different order. The first two are 
do not actually affect the loop, other than taking the same number 
of cycles as the corresponding portion of the loop in delaycal. 

Note that both loops consist of: 

ADD, ADC, CMP, Jcond 

************************************************************* 


loopl: 


adc 

cmp 

add 

jnz 


dx ,0 

dx,dummy 
ax, 1 
loopl 


kill some time 
and some more 
increment our count 
no, continue looping 


;****★♦*****★***********♦♦******♦************♦♦*************** 

ret 

del500u endp 


This Is essentially the same as del500u, except that a different 
count value is used to delay for 2 milliseconds. 


del 2m 


pub Iic 
proc 
assume 
mov 
neg 


de I 2m 
near 

ds:dgroup 
ax,ms2 
ax 


II vy W ^ 

;**************************************** 


********************* 


loop2: 

adc dx,0 

cmp dx,dummy 


kill some time 
and some more 


( continued ) 
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add ax,1 

jnz loop2 

;****************+*+++++++++++ 

ret 

del 2m endp 
prog ends 
end 


; Increment our count 
• no, continue looping 
**************+***++++++++++++++ 


title LISTING 6 ;DETECTING VIDEO TYPE 

i Video.asm is the Lattice C-caltable assembly language routine that determines 
| system*** 00 * ° 8Cree " odopt#r cards ond displays in an IBM compatible 

; *NOTE* The timing loops have only been validated on 6 Mhz. AT 

; Copyright (c) 1986 Dan Jacobs and Joel Rosenblum 

; portions copyrighted by Hercules Corp. and International Business Machines Corp. 
j Jol.°2?°N*. C lT-i* t * U8t ° f tH * EGA 0d ° Pt#r C ° rd S#e IBM S#m,nor Proceedings 


name video_test 
Include dos.mac 


;determlne video adapter card 


; Lattice C memory model configuration macro 
; In this case it is a copy of dm8086.mac 

• *NOTE* all the below equates must be the same as listl.c 


IBM Color graphics adapter (CGA) 

IBM Monochrome card 

Hercules monochrome graphics card 

Professional graphics controller (PGA) 

IBM Enhanced graphics adapter (EGA) w/monochrome display 
EGA w/color display 7 

EGA w/high resolution color display 
Unknown board type 


; video mode equates 


CGA 

equ 

01H 

MONO 

equ 

02H 

HERCULES 

equ 

04H 

PGA 

equ 

08H 

EGA_MONO 

equ 

10H 

EGA.COLOR 

equ 

20H 

EGA_HIGH 

equ 

40H 

UNKNOWN 

equ 

80H 

; machine type 

equates 


IBMCOMPAT 

equ 

0100H 

I8MPC 

equ 

0200H 

IBMPCAT 

equ 

0400H 

IBM_CONVERT 

equ 

0800H 

; global equates 


VIDEO_IO 

equ 

10H 

GET_MODE 

equ 

0FH 

DSEG 



video_type 

db 

? 

t_features 

dw 

? 


BIOS video i/o interrupt number 
video i/o get mode function 


place to accumulate the video type 
machine discriptor passed to function 


ENDDS 


PSEG 


commentX********************************,**,,**,,,,*,,,*^^^^,,,,,^^^^^^^^^^^^^^^^^^^ 

NAME 

Video_test - checks to see which video adapter and display are used 


SYNOPSIS 

unsigned int Video_test (features); 
unsigned features; 


see definition of machine 


RETURN VALUE 

type of video board used 

01H = Color graphics adapter 

02H = Monochrome card 

04H * Hercules card 

08H * Professional graphics adapter 

10H = EGA w/monocrome display 


type 
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20H « EGA w/color dispicy 

40H * EGA w/high resolution color display 

80H * Unknown video card 


IBM 


* ****************************************** 


pub lie video_test 


video_test 


proc near 


push bp 

mov bp, sp 


save the frame pointer (if called from C) 


; next, save the passed existing features 

mov ax, 4[bp] 

mov t_features, ax 


; Unfortunately this method of checking the EGA requires the use of 
; BIOS routines. Therefore, it can only be used on compatible 
; machines. We first, however, determine if we can make the BIOS call. 


; We use FEATURES to check if the BIOS int 10 
; is available for use. 


test t_features, IBMCOMPAT + IBMPC + IBMPCAT 

jz ega done ; can only do this test on compatible 


mov 

ax, 

1200H 

mov 

bl . 

10H 

mov 

bh. 

0FFH 

mov 

cl , 

0FH 

int 

VIDEO_IO 


video alternate select 
return EGA info 
invalid data for test 
reserved switch setting 
returns with bh - color or mono mode 
bl * memory value 
ch ■ feature bits 
cl - switch setting 


emp 

jge 


emp 

jg 


emp 

jg 


cl, 0CH 
ega_done 
bh, 01H 
ega_done 
bl, 03H 
ega_done 


test switch setting 
above max setting 
test range 0 - 1 
above range 

check memory value for 0-3 range 
above range 


; if it gets here, there is a EGA card present 
; now test for the attached monitor 


and 

emp 

je 

emp 

jne 

is_m: or 

jmp 

color: emp 

je 

emp 

Jne 

is_c: or 

jmp 

enh_d: emp 

je 

emp 

jne 

is_enh: or 


cl, 0EH 
cl, 1010B 
i s_m 

cl. 0100B 
color 

video_type, EGA_MONO 
short ega_done 
cl, 1000B 
i s_c 

cl, 1110B 
enh_d 

video..type, EGA_COLOR 

short ega_done 

cl, 1100B 

is_enh 

cl, 0110B 

ega_done 

video_type, EGA_HIGH 


; trim the switch to the bits we need 
; monochrome monitor attached ? 

; secondary mono setting ? 

; nope check color display 
; set EGA card with monochrome display 

; primary color display ? 

; secondary color ? 

; check for high resolution display 
; EGA card with color display 

; primary high resolution display ? 

; secondary high resolution display ? 

; EGA card with high resolution color display 


ega_done: 


check for Hercules cord is present by checking the status port 

ot 3BAH for the vertical retrace bit. . . .. . 
♦♦NOTE** you can also tell the mode the card is in and set the card 
mode For more information, contact Hercules technical support. 


mov dx,3BAH 

in a I,dx 


address of status port 


(continued) 
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and 

al,80h 

; vertical retrace bit 

mov 

ah,al 

; Save bit 7 for test 

mov 

examine: 

cx,8000h 

; count for delay loop 

in 

a 1 , dx 

; Take another reading 

and 

al,80h 

; Isolate bit 7 

cmp 

al ,ah 


Jne 

Is_hercu1es 

; If bit 7 changes then it 

1 oop 

examine 

; is a Hercules Graphics Card 

Jmp 

check_color 

; After this long, it must be 
; somethina else. 

is_nercules: 

or 

video_type, 

HERCULES 

jmp 

short check. 

-P9° ; don’t check for mono or color 

; board if Hercules present 

check_color: 

test 

video_type, 

EGA_COLOR + EGA.HIGH 

Jnz 

check_mono 

; can't have a color card with 
; EGA in color mode 


; next check for a Color 
; presence of the cursor 
mov dx, 03D4H 

caI I cursor_reg 

Jc check_mono 

or video_type, CGA 

check_mono: 

test video_type, EGA_MONO 
Jn 2 check_pga 


for the 

; carry flag set If not there 
; there is a color graphics adapter 

; can't have mono card in machine 
; with EGA in mono 


Graphics Adapter by the checking 
register at 0x304 


; fi 
; pr 
mov 
ca I I 
Jc 
or 


rst check for a monochrome board by checking for the 
esence of the cursor register at 0x3B4 
dx, 03B4H 

cursor_reg ; carry flag set if not there 

check_pga 

video_type, MONO ; there is a monochrome adapter card 


check_pga: 

; now test for a Professional Graphics Adapter by checking the 
; status register which is memory mapped to address C600:03DB 


cursor 


push es 

mov ax, 0C600H 

mov es, ax 

mov di, 03DBH 

mov ah, es:[di] 

mov byte ptr es:[di], 5AH 

mov al, byte ptr es:[di] 

mov byte ptr es:[di], ah 

cmp a I, 5AH 

pop es 

jne check_done 

or video_type, PGA 


; load segment 

; load offset 
; save the original value 
; test value 
; read it back 
; restore original 

; clear stack 
; no PGA adapter 
; yes, it’s there 


check_done: 

cmp video_type, 0 

jne exit 

mov video_type, UNKNOWN 


When all else fails... 
can't recognize any card 


exit: xor 

mov 


ax, ax 

a I, v1deo_type 


clear ah 


pop bp 
ret 


restore frame pointer to return to C caller 


video_test endp 


commontX******************************* 
NAME 

cursor_reg 
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SYNOPSIS 

checks to see If there is a cursor register at the 
address passed in dx 

RETURN VALUE 

carry clear - if cursor register present 
carry set - no cursor register here 

*****************************************************************************\ 


eg 

proc near 


mov 

al. 0FH 

set the index to the cursor register 

out 

dx, a 1 


1 nc 

dx 

increment to data register 

i n 

a 1, dx 

get the original value 

xchg 

al, ah 

save it for later 

mov 

a 1, 5AH 

test value 

out 

dx, a 1 

set cursor control register 

jmp 

$+2 

waste some time 

jmp 

$+2 


jmp 

$+2 


1 n 

a 1 , dx 


cmp 

a 1, 5AH 

; same as written ? 

xchg 

a 1 , ah 

; restore saved value 

out 

dx, a 1 

; it was the control register 

je 

yup 

stc 

ret 

; no cursor return code 

c 1 c 
ret 


; is there return code 


cursor_reg endp 

ENDPS 

end 


PERPROPC.C 

"Performance Programming," by Joel Rosenblum and Dan 
Jacobs. Inside the IBM PCs, Extra Edition, page 181. 


/* 

*/ 


LISTING 1 - AN EXAMPLE FEATURES TABLE 


This code contains a C language Features Table which contains the location 
and copyright string that uniquely identify a machine. In addition to the 
copyrights, the bit fields for the FEATURES and VIDEO_FEATURES variables 
are defined. Note that this code is compiled with the Lattice C Compiler 
version 2.15, using -md -n options. Copyright (c) 1986 Dan Jacobs and 
Joel Rosenblum for public, unrestricted use. 


/* bit flags for FEATURES */ 


#define 

IBMPC 

0x0100 

/* 

^define 

IBMPCAT 

0x0200 

/* 

#define 

IBMCOMPAT 

0x0400 

/* 

#define 

IBM CONVERT 

0x0800 

/* 

|define 

GENERIC 

0x1000 

/* 

#define 

NO_DMA 

0x2000 

/* 

#define 

WANG 

0x4000 

/* 

#define 

TIPROF 

0x8000 

/* 

#def ine 

CPU.88 

0x0001 

/* 

|define 

CPU.186 

0x0002 

/* 

#define 

CPU_286 

0x0004 

/* 

#define 

CPU_V20 

0x0008 

/* 

|def 1 ne 

NDP 

0x0010 

/* 


IBM PC, XT, Portable, */ 

IBM AT */ 

IBM PC BIOS Compatible */ 

IBM ConvertibIe */ 

Assumed Generic PC */ 

Machine has no DMA */ 

Wang PC Special Case*/ 

TI Professional PC Special Case */ 
8088, 8086 Processor */ 

80188, 80186 Processor */ 

80286 Processor */ 

V20, V30 Processor */ 

8087, 80287 Math Co-processor */ 


/* bit flags for VIDEO.FEATURES */ 


(continued) 
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#deflne CGA 
#define MONO 
#defIne HERCULES 
#define PGA 
#define EGA.MONO 
#define EGA_COLOR 
#deflne EGA.HIGH 
#define UNKNOWN 
#define ANSI 


0x0001 /♦ IBM Color Grophics Adapter ♦/ 

0x0002 /♦ IBM Monochrome Adapter ♦/ 

0x0004 /♦ Hercules Monochrome Adopter Cord ♦/ 

0x0008 /♦ IBM Professional Grophics Adapter ♦/ 

0x0010 /♦ w/Monochrome Monitor ♦/ 

0x0020 /♦ w/Color Monitor ♦/ 

0x0040 /♦ w/HIgh Resolution Color Monitor ♦/ 

0x0080 /♦ Unknown Graphics Type ♦/ 

0x0100 /♦ ANSI.SYS Installed ♦/ 


/* Additional bit fields may also be defined, please see TABLE 1 for suggestions ♦/ 
struct machine_lnfo { 

char *logo; /♦ Unique copyright string ♦/ 

long addr; /♦ String memory location ♦/ 

/* Note: actually (char ♦ ) must be (long) to pass lattice C ♦/ 

Int type; /♦ Machine attributes ♦/ 

} feoture_table[] - } 


/* 


copyright notice, physical oddress, pctype ♦/ 


”IBM". 0xF E00E L, IBMPC11BMCOMPAT}, 
"COMPAQ", 0xFFFEAL, IBMCOMPAT}, 
"Corona", 0xFE00F, IBMCOMPATj, 
"Corona", 0xFE01A, IBMCOMPAT , 
"M.P.C.". 0xFD82D, IBMCOMPAT}. 
"Columbia", 0xFF768, IBMCOMPAT}, 
"Eagle PC". 0xFFFAA, IBMCOMPAT}, 
"Eogle PC", 0xFF810, IBMCOMPAT}, 
"Zenith", 0xFB000, IBMCOMPAT}, 
"Zenith", 0xFC2FF, GENERIC}, 
"MITSUBISHI", 0XFC02A, IBMCOMPAT}, 
"TVS". 0XFE003, IBMCOMPAT{, 

"OSM", 0XFFFF5, IBMCOMPAT}, 

"OLIVETTI", 0xFC050, IBMCOMPAT}, 

"WANG", 0xFFFC2, WANG|GENERIC}, 

"ADDS", 0XFC050, IBMCOMPAT}, 

"CROS", 0xFE000, IBMCOMPAT}, 

"PCPI", 0xFE00F, IBMCOMPAT , . 

"TAVA", 0xFE018, IBMCOMPAT}, 

"Tandy", 0xFC02B, IBMCOMPATjNO_DMA}, 

} "Tandon", 0xFC013, IBMCOMPAT{, 

| "Texas", 0xFE022, TIPROF}. 

} "American", 0xFE004, IBMCOMPAT}, 

I "STD", 0XFE00EL, IBMCOMPAT}, 

| "STD", 0XFFFEAL. IBMCOMPAT}, 
j "TOMCAT", 0xFE028, IBMCOMPAT}, 
j “WYSE". 0XFC003, IBMCOMPAT}, 
j "Hewlett-Packard", 0xF0024, IBMCOMPAT} 
} "Morrow", 0xFE073, IBMCOMPAT}, 


/♦All IBMs ♦/ 

/♦All COMPAQs ♦/ 

/* Old Version Corona ♦/ 

/♦ Version 3.10 ROM Corona (also Phillips) ♦/ 
/* New Columbia ♦/ 

/♦Old Columbia ♦/ 

/♦ Eagle PC ♦/ 

/♦ Eagle PC Plus ♦/ 

/♦ Zenith Data Systems ♦/ 

/♦ Zenith 100 ♦/ 

Sperry PC and Leading Edge ♦/ 

Televldeo ♦/ 

OSM Rom Version 3.6 or later ♦/ 

AT&T-IS PC6300 and Xerox ♦/ 

NOTE: AT&T is not supporting VI.0 ROMs ♦/ 
WANG professional ♦/ 

/♦ Applied Data Digital Systems Model PC/I ♦/ 
/♦ Seattle Telecom Turbo Boards ♦/ 

/♦ Personal Computer Products ♦/ 

/♦ Tava PC ♦/ 

/♦ Tandy 1000 has no DMA unless memory upgrade 
board installed ♦/ 

/♦ Tandy 1200 ♦/ 

/♦ TI Professional VI.23 & V2.11 SYSROM ♦/ 

/♦ American PC lookalike ♦/ 

/♦ STD Turbo Boards in IBMs ♦/ 

/♦ STD Turbo Boards in COMPAQs ♦/ 

/♦ Tomcat AT clone ♦/ 

/♦ WYSE PC BIOS Version 1.08 ♦/ 

/♦ Hewlett-Packard Vectra AT Compatible ♦/ 

/♦ Morrow Pivot II & Zenith 171 Desktops ♦/ 


/* 

/* 

/* 

/♦ 

/* 

/* 


/♦ Additional machines are added to the list starting here ♦/ 
} NULL. NULL. 0} 



/♦ 

*/ 


LISTING 2 - DETERMINING MACHINE COMPATIBILITY 


This code shows how the Features Table is used to set up 
the bit flags In the FEATURES variable. Once FEATURES 
is set for the current machine, your other program 
modules can use it to determine what section of code 
should be executed to yield the best program performance. 

Copyright (c) 1986 Dan Jacobs and Joel Rosenblum 


Compiled using Lattice C ver 2.15, 

*/ 


using -md -n options 
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unsigned int video_features; 


/* global variable which holds video attributes */ 


unsigned int set_features() 

1 

char *cp; 

struct machine_info *p; 
unsigned int feature; 


/* Pointer */ 

/* Features Table Structure */ 

/* FEATURES bit field variable */ 


/* Assume the PC is generic to start */ 

feature = GENERIC; /* default to generic */ 


A psuedo code example of how 
assuming that either a slash 
set. Your actual code will 
the section on "using the 
compatibility" in our text. 


to override the automatic set of FEATURES 
option or an DOS environment variable is 
depend upon how you do the parsing. See 
machine’s copyright notice to determine 


begin pseudo code example — 


if ((/IBM entered on command line) | 

(compatibility = IBM is in the environment)) { 
feature ** IBMCOMPAT; 
goto cpu_test; 

\ 

— end psudo code example */ 


for (p = feature_tabIe; p->addr 1= NULL; p++) /* if next table entry is NULL, then end loop */ 
if (strncmp((char *) p->addr, p->logo, strIen(p->logo)) *= 0) { 
feature = p->type; 
break; 

1 


if (feature & IBMPC) { 

cp « (char *) 0xFFFFE; 
switch (*cp) { 

case 0xF9: /* IBM Convertible */ 

feature |= IBM_CONVERT; 
break; 

case 0xFC: /* IBM AT */ 

feature |= IBMPCAT | CPU_286; 
break; 

case 0xFD: /* IBM PC JR */ 

feature |« NO_DMA; 
break; 

case 0xFE: /* IBM XT or Portable */ 
case 0xFF: /* IBM PC */ 

break; 
defauIt: 

break; /* unknown IBM type */ 


/* IBM Personal Computers */ 

/* physical address 0FFFF:E */ 


I 


i 


/* add the cpu type to FEATURES 
feature » cputest(feature); 


see listing 3 */ 


/* check for numeric data processor — see listing 4 */ 
feature = test_ndp(feature); 


/* add the video display type to VIDEO_FEATURES — see listing 6 */ 
video_features * video_test(feature); 


/* check if ANSI.SYS 
if (check_ansi()) { 
video_features |* 
\ else { 

putchi0x0D); 


putch( 
putch( 
putch( 
putchf* 
putch(0x0A); 
putch(0x0D); 


/* 

/* 


is present — see listing 7 */ 

ANSI; 

this cleans up any garbage left on the screen */ 
by the ansi check if ANSI.SYS is not present */ 


[continued) 
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return (feature); 


/* 

LISTING 5B - ILLUSTRATION OF TIMING DELAYS, C CALLING ROUTINE 

*/ 

/* 

This driver provides an example of how to use cal.asm for 
delay calibrate routines. The routine will print the delay 
according to the speed of the processor. The closer you 
make the loops to your actual code, the more accurate the 
calculation will be. You should then adjust your actual 
program delay proportional to the results of this test. 

*/ 

#include <stdio.h> 

static char id[] = "#PROGRAM: calibrate driver (hzm)"; 

/* 

♦ GIobaI var tables: 

*/ 


Int us500; 

Int ms2; 

/* 

* init — calibrate the delay counters 
*/ 

statIc 


us500 = deIaycaI(500); 
ms2 * deIaycaI(2000); 

printf("%d loops equals 500 microseconds.\n", us500); 
prInt f("%d loops equals 2 ml I I I seconds An", ms2); 


/* 

* delayl — delay for .5 sec (* 1000 * 500 usee) 

*/ 

static 
delay1() 

\ 

char before[4]; 
char after[4]; 

int I; 

printf("\nNow, delay 1000 * 500 usec...\n M ); 
dostime(&before); 

for (i = 0; i < 1000; i++) del500u(); 
dostime(&after); 

printf(" Start: %02d:%02d:%02d.%02d\n", 

before[1], before[0], before[3], before[2l); 
P rIn t f(” End: %02d:%02d:%02d.%02d\n", 

after[1], after[0], after[3], after[2]); 


/* 

* delay2 — delay for 4.0 sec (= 2000 * 2000 usee) 
*/ 

static 
deIay2() 


char before[4]; 
char after[4]; 

int i; 

printf("\nNow, delay 2000 * 2000 usec...\n M ); 
dostime(&before); 

for (i = 0; i < 2000; i++) de!2m(); 
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dostime(&ofter); 

p r in t f( M Start: %02d:%02d:%02d.%02d\n" 
before[l], before[0], before[3] 
pr I nt f(" End: %02d:%02d:%02d.%02d\n" 

after[l], after[0], after[3], a 


* driver main program: 
*/ 

main(argc, argv) 

int argc; char *argv[]; 


delaylQ; 
deIay2(); 
exit(0); 


/* 

*/ 

/* 


LISTING 7 - TEST FOR PRESENCE OF ANSI.SYS 


This code contains the check for the presence of ANSI.SYS. If 
found, the appropriate bit in VIDEO_FEATURES is set. This code 
is called from listing 2 and is compatible with the Lattice C 
CompiIer. 

Copyright (c) 1986 Dan Jacobs and Joel Rosenblum 
Compiled using Lattice C ver 2.15, using -md -n options 

*/ 

^include "dos.h" 

#define FAIL 1 
#define OK 0 

#define ANSI 1 
#define NOT_ANSI 0 

int line, Iine2, column, column2; 


union REGS in, out; /* defined in dos.h file of Lattice C Compiler */ 



NAME 


check_ans1 


SYNOPSIS 


Checks to see if ANSI.SYS is installed on your machine 
by doing an ansi "report cursor position" call twice 
in a row to make sure each call returns a value, and 
that the values match for two successive calls. For 
further information on ANSI.SYS, see the IBM DOS 
technical reference. 

RETURN VALUE 

1 If ansl.sys is installed 
0 otherwise 

t****************************************************************************/ 

check_ansi() 

1 

dump_key_buffer(); 

cputs("\x1B[6n"); /* report cursor position command */ 

if (get_llne_column I \ 


dump_key_buf fer 
return NOT_ANSI; 



/* no cursor position came in */ 


I continued ) 
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\ 

Ilne2 - line; /* save the reported values */ 

coIumn2 * column; 

dump_key_buf fer(); 

cputs("\x1B[6n"); /* try It one more time */ 

If (get_line_coIumnf)) } 
dump__key_buf f er ( ); 
return NOT_ANSI; 


dump_key_buf fer(); 

If (I In e2 I* line || column2 !* column) return NOT_ANSI; 
return ANSI; 


NAME 

get_I Ine_coIumn 

SYNOPSIS 

checks to see If there are two keystokes 
the keyboard buffer (K.B.) and If so, 
them In the global variables line 
coIumn. 



get_I lne__column() 


If (!(I ine = check_key())) return FAIL; 
if (!(coIumn =* check_key())) return FAIL; 
return OK; 


NAME 

check_key 

SYNOPSIS 

returns keystroke left in K.B. if o keystroke exists there 



check_key() 

i 

Int c; 

for (c = 0; c < 100; c++) 

; /* do nothing but wait */ 

in.h.dl = 0xFF; 
in.h.ah = 0x6; 
c = intdos(&in, &out); 

If (c & 0x40) return 0; 
return (int)out.h.aI; 


NAME 

dump_key_buffer 

SYNOPSIS 

clears K.B. 
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dump_k ey_buf f e r() 

in.h.dl - 0xFF; 
in.h.al = 0x06; 
in.h.ah = 0x0C; 
intdos(&in, &out); 


/* 

*/ 


LISTING 8 - EXAMPLE VIDEO CHARACTER OUTPUT ROUTINE 


This code contains a C language example that uses the bit 
fields contained within the FEATURES variable to determine 
if it is possible to display the IBM extended character 
set on the machine. We assume these characters may be 
displayed if the machine is IBMCOMPAT. Note that this 
may be called from other modules in your program without 
regard to hardware considerations. 

Copyright (c) 1986 Dan Jacobs and Joel Rosenblum 


Compiled using Lattice C ver 2.15, using -md -n options 

•/ 

extern unsigned int features; /* see definition */ 


/* position of characters in box_char */ 


#define TOP_LEFT 0 
#define TOP_SIDE 1 
#define TOP.RIGHT 2 
#define SIDES 3 
^define BOTTOM.LEFT 4 
#define BOTTOM_SIDE 5 
#define BOTTOM_RIGHT 6 


char box_char[2][7] ■ \ 

{0xDA, 0xC4, 0xBF, 0xB3, 0xC0, 0xC4, 0xD9|, /* expanded char codes */ 
{0x2B, 0x2D, 0x2B, 0x7C, 0x2B, 0x2D, 0x2D{ /* replacement char codes 

to use when no extended 
codes can be used */ 


/+ + + + * + + ** + + ^******** + ********4:*****>f**** + ******)tc************ : + : ***4: + *** + * ) | ( * + + + + 

NAME 

draw_box 

SYNOPSIS 

Draws a box of size, length, and width at the row 
and column specified. Notice how the characters 
used for the box are changed based on the 
availability of the extended set. (Those 
characters only exist on IBM compatibles). 

It*********************** ** *♦*** + ♦♦♦♦* + + + ^ + + + + + + + + *******/ 

draw_box(row, column, length, depth) 
int row, column, length, depth; 

int i; 

int char_set; /* tells which row of box_char to use based 
on the the IBMCOMPAT bit In features, use row 
0, which contains extended chars, if IBMCOMPAT 
otherwise, use row 1 which contains standard 
ASCII replacements for the extended set */ 

char_set * features k IBMCOMPAT ? 0 ; 1; 

move_cursor(row, column); /* First, draw left corner */ 

/* Move_curser is in listing 9. It moves the cursor to row, column 
by determining the machine’s video features contained in the bit 

( continued ) 
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flags In FEATURES. You notice that your program does not need 
to worry about the details of how to move the cursor depending 
upon which machine Is used. That leaves you free to solve more 
important problems */ 


putchars(box.char[char.set][TOP.LEFT], 1); 

/* Putchars Is a routine which puts the char passed In the first arg 
out to the screen the number of times specified by the second arg. 
Putchar also decides which method it will use to output that char 
based on the type of equiptment installed on your machine. See 
listing 9 for move.cursor detail */ 

move.cursor(row, column+1); /* now the top side */ 

putchars(box.char[char.set][TOP.SIDE], Iength-2); 

move.cursor(row, coIumn+Ienath-1); /* next top right corner */ 
putchars(box.char[char.set][TOP.RIGHT], 1); 

for(i - 1; | < length-1; I++) j /* Vertical sides */ 
move.cursor(row+i, column); 
putchars(box.char[char.set][SIDES], 1); 
move.cursor(row+I, coIumn+length-1); 
putchars(box.char[char.set][SIDES], 1); 


move.cursor(row+length-1, column); /* bottom left corner */ 
putchars(box.char[char.set][BOTTOM.LEFT], 1); 

move.cursor(row+Iength-1, column+1 ); /* bottom side */ 
putchars(box.char[char.set][BOTTOM.SIDE], Iength-2); 

move.cursor(row+Iength-1, coIumn+Iength-1); /* bottom right corner */ 
putchars(box.char[char.set][BOTTOM.RIGHT], 1); 


\ 


/* 

LISTING 9 - EXAMPLE VIDEO CURSOR POSITIONING ROUTINE 

*/ 

/* 

This routine handles the details of cursor positioning based on 
the bits set in the variables FEATURES and VIDEO.FEATURES. It 
is called from the draw.box routine in listing 8, and illustrates 
how common machine dependent routines should be written. Note 
a similar type of routine should exist in your program to handle 
bit-mapped graphics-related calls. 

Compiled using Lattice C ver 2.15, using -md -n options 

*/ 

extern unsigned int features; /* global variable which holds machine features */ 

extern unsigned int video.features; /* global variable which holds video-related features */ 


char *screen.buff; /* pointer to buffer of 2000 (80*25) chars which is big 

enough to hold the ASCII charactures for a complete 
video page */ 

char *screen.pos; /* pointer into screen.buff at current cursor position */ 


char page.no; 


/* previously set video page number */ 


char string[80]; 


/* string to use for ASCII calls */ 


NAME 

move.cursor 
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SYNOPSIS 

moves the cursor to row, column on the 
note that the routine decides which 
based on bits set in both FEATURES and 


video display 
method to use 
VIDEO.FEATURES 


***********♦******************♦*********************************♦******♦**★**/ 


move_cursor(row, column) 
int row, column; 

\ 

union REGS Inregs, outregs; /* defined in dos.h */ 


if (features & IBMCOMPAT) { 
inregs.h.ah » 2; 
inregs.h.dl * column; 
inregs.h.dh ■ row; 
inregs.h.bh = page_.no; 
int86(0x10, &inregs, &outregs) 
} else if (video_features & ANSI) 
sprintf(string, "\x1B[%d;%df$" 
dos_puts(string); /* dos_puts 
prints sti 

} else { /* dos generic mode */ 
screen_pos = screen_buff + row 


/* use int 10 video bios */ 
/* set cursor position */ 


/* page number */ 

/* do bios int 10 */ 

/* need to do ansi calls */ 

++row, ++column); 
s a routine that calls dos and 
ing using function 9, print string */ 

* 80 + column; 


i 


/* NOTE: In DOS generic mode we keep a buffer (screen_buff) 
big enough to hold one video page of ASCII text. In all 
of the calls that write to video, we move the chars into 
screen_buf at the pheudo cursor position, screen_pos. 
When we have completed updating the memory-based page, 
we write the ASCII chars from the memory buffer to the 
actual screen using standard dos calls */ 


PM_AT.ASM 

"A Protected-Mode Program for the PC AT," by Ross 
P. Nelson. Inside the IBM PCs, Extra Edition, page 123. 


NAME PM_AT 

PAGE 60, 132 

.286C 

PM/AT - A program to place the PC/AT into Protected Mode 
Copyright 1985, Ross P. Nelson 


INCLUDE \usr\incIude\protect.inc 


; Data structure definitions 


DESCRIP 

STRUC 


; generic descriptor format 

limit 

DW 

? 

; offset if gate 

phys_addr_lo 

DW 

? 

; selector if gate 

phys_addr_hi 

DB 

? 

; wc if gate 

access 

DB 

? 

; access rights 

DESCRIP 

DW 

ENDS 

0 

; reserved for 386 

TSS.BLOCK 

STRUC 


; format of a TSS 

back_J i nk 

DW 

? 

; previously active TSS 

rSP0 

DW 

? 

; level 0 stack 

rSS0 

DW 

? 


rSPI 

DW 

? 

; level 1 stack 

rSSI 

DW 

? 


rSP2 

DW 

? 

; level 2 stack 

rSS2 

DW 

? 


rIP 

DW 

? 


FLAGS 

DW 

? 
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rAX 

DW ? 


rCX 

DW ? 


rDX 

DW ? 


r BX 

DW ? 


rSP 

DW ? 


rBP 

DW ? 


r$I 

DW ? 


rDI 

DW ? 


rES 

DW ? 


rCS 

DW ? 


rSS 

DW ? ; 

active stack segment 

rDS 

DW ? 

task_LDT 

DW ? ; 

LDT selector 

TSS_BLOCK 

ENDS 


; Literal values for descriptor types 


TSS 

EQU 1 


LOT 

EQU 2 


TSS — BUSY 

EQU 3 


CALLEGATE 

EQU 4 


TASK_GATE 

EQU 5 


I NEGATE 

EQU 6 


TRAPJSATE 

EQU 7 


RDONLY 

EQU 0 

read only 

RD_WR 

EQU 1 

read/write 

RD_WR_XD 

EQU 3 

read/write expand down 

EXONLY 

EQU 4 

execute only 

EX_RD 

EQU 5 

execute/readab1e 

EXONLY_CF 

EQU 6 

execute only/conforming 

EX_RD_CF 

EQU 7 

execute/readab1 e/conforming 

TSS_LIMIT 

EQU 43 


; Segment bu 

i1dIng macros 


MSEG 

MACRO name,type,priv,combine 

; start a memory segment 

name 

SEGMENT PARA combine 

; MASM directive 

zero * $ 


; for ALIGN macro 

&name&_start 

= $ 

; origin 

&name&_ar = 

90h OR (pr1v SHL 5) OR (type SHL 1) 
ENDM 

; access rights 


SSEG 

MACRO 

name,type,prIv 

;; start a system segment 

name 

zero * $ 

SEGMENT 

PARA 

;; MASM directive 
;; for ALIGN macro 

&name&_start 

= $ 


;; origin 

&name&_ar = \ 

B0h OR (priv SHL 5) OR type 

ENDM 

;; access rights 

ENDSEG 

MACRO 

name 

;; terminate a segment 

&name&_limit 

= $ - &name&_start - 1 

;; create variable for seg limit 

name 

ENDS 

ENDM 


;; 1imit <- size-1 (0-FFFFh) 

; Descriptor 

bui1ding macros 


DSCRP 

MACRO 

export,name 

;; build descrip for segment 


IFDIF 

<export>,<> 

;; check for export name 

export 

LABEL 

ENDIF 

WORD 


DW 

&name&_limit 

;; segment limit 


DW 

name 

;; 16-bit segment addr 


DB 

0 

;; high order addr 


DB 

&name&_ar 

;; access rights 


DW 

ENDM 

0 

;; reserved 

GATE 

MACRO 

export.offset,select 

,wc,type,priv ;; build descriptor 


IFDIF 

<export>,<> 

;; check for export name 

export 

LABEL 

ENDIF 

WORD 


DW 

offset 

;; offset 


DW 

se1ect 

;; segment se1ector 


DB 

wc 

;; word count 


DB 

80h OR (priv SHL 5) 

+ type ;; access rights 


DW 

ENDM 

0 

;; reserved 
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; Selector creating macros for Task segments 


GDT_SEL 

MACRO 

se1,priv 



DW 

ENDM 

se1 + priv 

;; assume sel » index * 8 

LDT_SEL 

MACRO 

se1,priv 



DW 

ENDM 

se1 + 4 + priv 

;; like GDT but TI bit set 

; Utility 

macros 



CALL.EX 

MACRO 

se1,rp1 

;; call exported itern 


DB 

9Ah 

;; FAR cal 1 


DW 

0 

;; no offset 


DW 

ENDM 

sel + rpl 

;; selector with req. priv. 

ALIGN 

MACRO 

bound 

;; align $ on power of 2 bounds 


LOCAL 

diff 


diff = 

(($ - zero) AND (bound - 

1)) ;; distance from bound 


IF 

diff NE 0 

;; if on bound skip 


ORG 

ENDIF 

ENDM 

$ + (bound - diff) 

;; else adjust 



PAGE 




This segment contains the Global Descriptor Table 


MSEG GDT,RD_WR,0 
; Required by INT 15 

DESCRIP <0,0,0,0> 

DSCRP int15_gdt.dat.GDT 

DSCRP int15_idt.dat,IDT 

DSCRP ,DSC 

DSCRP ,DSC 

DSCRP ,DSC 

DSCRP ,INIT 

DESCRIP <0,0,0,0> 

DSCRP setup_tss,INIT_TSS 
; Mini BIOS 

DSCRP bio_dat.MBDAT 
DSCRP bios_seg.BIOS 
DSCRP disp_mono.MONOGRAM 
DSCRP dis p_color,COLOR_RAM 
; Fault handlers 

DSCRP task_df.FTASK8 
xtra8 DESCRIP <ftask8_limit,FTASK8,0,92h> 

DSCRP task.tf.FTASK10 
xtra10 DESCRIP <ftask10_limit,FTASK10,0,92h> 
DSCRP task.sf.FTASK12 
xtra12 DESCRIP <ftask12_limit,FTASK12,0,92h> 
DSCRP fauIt_dat,FDAT 
DSCRP fhandler.HAND 
DSCRP falias.FDAT 
; Shared I ibrary 

DSCRP share_lib.SHLIB 
GATE share_gate,shIib_start,share_lib 
; Second task 


GDT(0) always blank 

DATA -> GDT 

DATA -> IDT 

DATA -> DS 

DATA -> ES 

STACK -> SS 

CODE -> CS 

CODE -> BlOS/int 15 reserved 
TSS -> initial task 

DATA -> mini bios 

CODE -> mini bios 

DATA -> monochrome display 

DATA -> color display 

TSS -> double fault 
writable DATA alias for TSS 
TSS -> task fault 
writable DATA alias for TSS 
TSS -> task fault 
writable DATA alias for TSS 
DATA -> hand Ier 
CODE -> handler 
free for fault handler use 

CODE -> shared 

0,CALL_GATE,3 ; GATE to code 


DSCRP 

DSCRP 

; Future use 

DESCRIP 

DESCRIP 

DESCRIP 

DESCRIP 


task2_tss,TASK2 
task2_ldt.T2LDT 

<0 , 0 , 0 , 0 > 

<0 , 0 , 0 , 0 > 

< 0 , 0 , 0 , 0 > 

<0 , 0 , 0 , 0 > 

ENDSEG GDT 


; TSS for 2nd task 
; LDT for 2nd task 

; availab Ie 
; avaiIabIe 
; avaitable 
; avaitable 


PAGE 

This segment contains the Interrupt Descriptor Table. 


; Chip 


MSEG IDT,RD_WR,0 
level interrupts (0 - IFh) 

GATE .fau11_00,fhand Ier,0,TRAP.GATE,0 
GATE ,fau1t_01,fhand Ier,0,TRAP_GATE,0 
GATE ,fau11_02,fhand Ier,0,TRAP.GATE,0 
GATE ,f au11_03,f hand Ier,0,TRAP.GATE,0 


DIVIDE 

TRAP 

NMI 

BRKPT 
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GATE ,fault.04,(handler,0,TRAP.GATE,0 

GATE ,fau1t_05,fhand Ier,0,TRAP.GATE,0 

GATE ,fau11_06,fhand Ier,0,TRAP.GATE,0 
GATE ,f au1t_07,fhand Ier,0,TRAP.GATE,0 
GATE .0,t a s k_d f.0.TASK.GATE,0 

GATE . f au It_09,fhand Ier,0.TRAP.GATE,0 

GATE # 0.task.tf,0.TASK.GATE,0 
GATE ,f au11_11,f hand Ier,0,TRAP.GATE,0 
GATE ,0,task.s f,0,TASK.GATE,0 

GATE , f au I1_13,fhand Ier,0,TRAP.GATE,0 

GATE .unknown,fhandIer,0,TRAP.GATE,0 
GATE .unknown,fhand Ier.0,TRAP_GATE,0 
GATE .fau1t_16.fhand Ier,0,TRAP_GATE.0 
GATE ,unknown,fhand Ier,0,TRAP.GATE,0 
GATE ,unknown,fhand Ier,0,TRAP.GATE,0 
GATE .unknown,fhand1er,0,TRAP.GATE,0 

GATE .unknown,fhandIer,0,TRAP.GATE,0 

GATE .unknown.fhandIer,0,TRAP_GATE,0 
GATE .unknown,fhandIer,0.TRAP.GATE,0 
GATE .unknown,fhandIer,0,TRAP.GATE,0 
GATE .unknown,fhandIer,0,TRAP.GATE,0 
GATE .unknown,fhandIer,0,TRAP.GATE,0 
GATE ,unknown,fhandler,0,TRAP.GATE,0 
GATE .unknown.fhandIer,0,TRAP.GATE,0 
GATE .unknown,fhandIer,0,TRAP_GATE,0 
GATE .unknown,fhandIer,0,TRAP_GATE,0 

GATE .unknown,fhandIer,0.TRAP.GATE,0 

GATE ,unknown,fhand Ier,0,TRAP_GATE,0 

System Interrupts 

Hardware Level 0 (20-27) DOS equivalent 

GATE ,timer_Jnt.bios_seg,0,INT_GATE,0 

GATE ,kb_int,bios_seg,0,INT_GATE,0 

GATE ,rsrv_Int,bios_seg,0,INT_GATE,0 

GATE .com1_int.bIos_seg,0,INT_GATE,0 

GATE ,com2_int,bios_seg.0,INT_GATE,0 

GATE ,prn2_Int,bIos_seg,0.INT.GATE.0 

GATE .fd_int,bios_seg,0.INT.GATE.0 

GATE ,prn1_int,bios_seg,0,INT_GATE,0 

Hardware Level 1 (28-2F) 

GATE ,r t c_In t.b!o s_s e g.0.1NT_GATE,0 

GATE ,rsrv_lnt.bios_seg,0,INT_GATE,0 

GATE ,rsrv_int,blos_seg,0.INTJ5ATE.0 

GATE ,rsrv_lnt,blos_seg,0,INT_GATE,0 

GATE ,rsrv_Int,blos_seg,0,INT_GATE,0 

GATE .n287_int.bIos_seg.0.INT_GATE,0 

GATE ,hd_Int,bIos_seg,0,1NT.GATE,0 

GATE ,rsrv.Int,blos.seg,0,INT GATE.0 

Mini BIOS (30 - 31) 

GATE ,In t_30,bIos_s e g,0.TRAP.GATE.3 

GATE ,sw_reset,bios_seg,0,TRAP_GATE,0 

ENDSEG IDT 


INTO 

BOUND 

undef 

287 NAVAIL 
DBL FAULT 
287 OVRRUN 
TSS FAULT 
NP FAULT 
STACK FAULT 
GP FAULT 


287 ERROR 


vector 

8 

9 

A 

B 

C 

D 

E 

F 

70 

71 

72 

73 

74 

75 

76 

77 


PAGE 

Mini BIOS 

This section contains the "miniBIOS," a collection of 
routines for hardware support, including the interrupt 
handlers, and user-callable display routines. 


; PC/AT Hardware Control 



MSEG 

MONO_RAM,RD_WR,0,<AT 

0B000h> 


ORG 

4000 

; end of monochrome RAM 


ENDSEG 

MONO_RAM 



MSEG 

COLOR_RAM,RD WR,0,<AT 

0B800h> 


ORG 

16 * 1024 

; end of color RAM 


ENDSEG 

COLOR_RAM 


MASTER 

EQU 

20h 

; master 8259A 

SLAVE 

EQU 

0A0h 

; slave 8259A 

DEV_COLOR 

EQU 

3D4h 

; color port 

RETRACE_PORT 

EQU 

3DAh 

; port for horiz/vert retrace 

DEV_MONO 

EQU 

3B4h 

; monochrome port 

DEV.RTC 

EQU 

70h 

; real-time-clock port 

EOI 

EQU 

20h 

; end of interrupt command 
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WR_DEVICE 

MACRO 

dev i 

Ice,unit.data 

; write to rtc or crt devi 


IFDIF 

<device>,<> 



mov 

ENDIF 

dx, 

device 



mov 

al , 

un 11 



out 

dx, 

a 1 



i nc 

dx 




mov 

al. 

data 



out 

dx, 

a 1 



dec 

ENDM 

dx 





MSEG 

MBDAT,RD_WR,0 


tick_ctr 

DD 

0 

; incremented by timer int 

kb_ctr 

DW 

-2 

; keyboard interrupts 

; NOTE 

: This program is setup to 

run on a monochrome system only 

; This 

pointer must be modified to 

support a color display. 

display_ptr 

LABEL 

DWORD 

; points to display RAM 


DW 

0 

; offset 


DW 

disp_mono 

; selector (MONOCHROME) 

cursor 

LABEL 

word 


cursor_x 

DB 

0 

; column 

cursor_y 

DB 

0 

; row 

attr ib 

DB 

7 



ENDSEG 

MBDAT 



MSEG 

BIOS.EXONLY.0 



ASSUME 

CS:BIOS, DS:NOTHING 

; INTERRUPT 1 

HANDLERS 




; This is where the MINIBIOS comes when it gets a hardware interrupt. 

; In this implementation, the only interrupt which is handled is 

; the timer tick. The keyboard interrupt is also used as a signal 

; to exit protected mode. The other handlers are left as an 

; exercise for the user. 

; Level 0 interrupts 
timer_int: 

push 
push 
mov 
mov 

ASSUME 
i nc 
adc 
mov 
out 
pop 

ASSUME 
pop 
i ret 

kb_int: 

push 
mov 
out 
pop 
int 
I ret 

com1_int: 

push 
mov 
out 
pop 
I ret 

com2_int: 

push 
mov 
out 
pop 
I ret 


ax 

ds 

ax, OFFSET bio_dat ; data seg selector 

ds, ax 
DS:MBDAT 

WORD PTR tick_ctr ; bump counter 

WORD PTR tick_ctr[2], 0 

al, EOI ; signal 8259A 

MASTER, a I 

ds 

DS:NOTHING 
ax 


ax 

al, EOI 
MASTER, a I 
ax 

31h ; RESET system 


ax 

al, EOI 
MASTER, ol 
ax 


ax 

a I , EOI 
MASTER, a I 
ax 
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prn2_int: 

push 

ax 



mov 

alj EOI 



out 

MASTER. 

al 


pop 

ax 



l ret 



fd_int: 

push 

ax 



mov 

al. EOI 



out 

MASTER, 

al 


pop 

ax 



i ret 



prn1_int: 

push 

ax 



mov 

al. EOI 



out 

MASTER, 

al 


pop 

ax 



1 ret 




; Level 1 interrupts - 

must EOI both the SLAVE and MASTER 8259As 

rtc_int: 




push 

ax 


mov 

al, EOI 


out 

SLAVE, al 


out 

MASTER, al 


pop 

ax 


1 ret 


n287_int: 




push 

ax 


mov 

al, EOI 


out 

SLAVE, al 


out 

MASTER, al 


pop 

ax 


i ret 


hd_int: 




push 

ax 


mov 

al, EOI 


out 

SLAVE, al 


out 

MASTER, al 


pop 

ax 


I ret 


rsrv_int: 




int 

IFh ; cause failure 


PAGE 


; MiniBIOS user 

ca11ab 

le function codes 

MBIOS_WR_CHAR 

EQU 

0 

MBIOS_WR_STRING 

EQU 

1 

MBIOS_WR_CRSR 

EQU 

2 

MBIOS WR_ATTR 

EQU 

3 

MBIOS.BELL 

EQU 

4 

MBIOS.CLS 

EQU 

5 

; USER CALLABLE 

FUNCTIONS 

; INT 30h 



; Write to display — All registers but AX preserved 

> 

FN: 

AH = 0 Write character 

» 

Input: 

AL * char 

» 

» 

FN: 

AH = 1 Write ASCIIZ string 

» 

Input 

DS:SI -> string 

» 

i 

FN: 

AH = 2 Set cursor 

• 

Input: 

DH = row 

» 


DL = column 

» 

> 

FN: 

AH = 3 Set attribute 

> 

Input: 

AL =* attribute 

i 

» 

FN: 

AH = 4 Bell 
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int_30: 


wr_cursor 
; Write HW 


wr_cursor 

co: 


condone: 


I i nout: 


FN AH * 5 Clear Screen 


c I d 

or ah, ah ; determine function 

jz co 

dec ah 

jnz $ + 5 

jmp Iinout 

dec ah 

jnz $ + 5 

jmp set_cursor 

dec ah 

jnz $ + 5 

jmp set_attrib 

dec ah 

jnz $ + 5 

jmp be I I 

dec ah 

jnz $ + 5 

jmp els 

i ret 

PROC NEAR 

cursor - cursor in DX, trashes AX, CX, DX 

mov ax, 80 ; convert to 16 bit 

mu I dh 

xor dh, dh 

add dx, ax 

mov cx, dx 

WR_DEVICE DEV_MONO,14,ch ; write hardware 

WR_DEVICE ,15,cl 

ret 

ENDP 


push 

cx ; 

; save state 

push 

di 


push 

ds 


push 

es 


mov 

cx, OFFSET bio_dat 

; bios data segment 

mov 

ds, cx 

ASSUME 

DS:MBDAT 


1 es 

di, disp1ay_ptr 


mov 

ch, a 1 

save character 

mov 

ax, 80 * 2 

number of columns/row 

mov 

c1, cursor_y 

time #rows 

mu 1 

cl 


add 

d i, ax 

update offset 

xor 

o 

X 

o 

X 

zero 

mov 

a 1, cursor_x 

co1umn 

shl 

al, 1 

* 2 

add 

d i , ax 

update offset 

mov 

a 1 , ch 

restore character 

mov 

stosw 

ah, attrib 

get data 

i nc 

cursor_x 

ajust cursor position 

cmp 

cursor_x, 80 

Jb 

condone 


sub 

cursor_x, 80 


i nc 

cursor_y 


push 

dx 


mov 

dx, cursor 


ca 1 1 

wr_cursor 


pop 

dx 


pop 

es 


pop 

ds 


ASSUME 

DS:NOTHING 


pop 

di 


pop 

I ret 

cx 



push 

es 

; save state 

push 

s i 
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Iinout_loop: 


Iine_done: 


update_row: 


set_cursor: 


set_attrib: 


push 

di 


push 

cx 


push 

ds 


mov 

cx, OFFSET bio_dat 

; bios data segment 

mov 

ds, cx 


ASSUME 

DS:MBDAT 


1 es 

di, dl8play_ptr 

; get screen pointer 

mov 

ax, 80 * 2 

; number of columns/row 

mov 

c1, cursor_y 

; time #rows 

mu 1 

c 1 


add 

d I , ax 

; update offset 

xor 

ax, ax 

; zero 

mov 

a 1, cursor_x 

; column 

shl 

a 1 , 1 

; * 2 

add 

di , ax 

; update offset 

mov 

ah, attrib 

; screen attribute 

pop 

ds 

; user data 

ASSUME 

DS:NOTHING 


xor 

o 

X 

o 

X 

; count 

old 



1 odsb 



or 

a 1 , a 1 

; end of string? 

Jz 

1lne_done 

; yes - quit loop 

stosw 


; no - write char/attrib 

i nc 

cx 


jmp 

1inout_loop 

; write next char 

push 

ds 


mov 

ax, OFFSET bio_dat 

; bios data segment 

mov 

ds, ax 


ASSUME 

DS:MBDAT 


mov 

ax, cx 

; count 

mov 

cl , 80 


dl v 

cl 

; al * rows, ah * columns 

add 

cursor_x, ah 


cmp 

cursor_x, 80 

; overflow? 

Jb 

update_row 

; no 

sub 

cursor_x, 80 

; else adjust 

Inc 

al 


add 

cursor v, al 


push 

dx 


mov 

dx, cursor 


cal 1 

wr_cursor 


pop 

dx 


pop 

ds 


ASSUME 

DS:NOTHING 


pop 

cx 


pop 

dl 

; start of chars written 

pop 

s i 

; restore state 

pop 

es 


i ret 


; and return 


push 

cx 


push 

dx 


push 

ds 


mov 

ax, OFFSET bio_dat 

; bios data segment 

mov 

ds, ax 


ASSUME 

DS:MBDAT 


mov 

cursor, dx 

; save new cursor 

cal 1 

wr_cursor 


pop 

ds 


ASSUME 

DS:NOTHING 


pop 

dx 


pop 
i ret 

cx 



push 

cx 


push 

ds 


mov 

cx, OFFSET bio_dat 

; bios data segment 

mov 

ds f cx 


ASSUME 

DS:MBDAT 


mov 

attrib, al 


pop 

ds 


ASSUME 

DS:NOTHING 
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pop 
i ret 


cx 


bell: 



push 

ax 




push 

bx 




push 

cx 




mov 

bx. 

200 



in 

a 1 , 

61 h 

; get current state 


push 

ax 


; save it 

be 1l_loop: 

and 

al , 

0FCh 

; speaker off 


out 

61 h 

, al 



mov 

cx, 

60 


id 1 el: 

loop 

idlel 



or 

al. 

002h 

; speaker on 


out 

61h 

, al 



mov 

cx, 

180 

; duty cycle 1:3 

id 1e2: 

loop 

i d 1 e2 



dec 

bx 


; test major loop 


jnz 

be 1 l_Joop 


pop 

ax 




out 

61h 

, al 

; restore state 


pop 

cx 




pop 

bx 




pop 

ax 




I ret 




c 1 s: 

push 

cx 


; save state 


push 

dx 




push 

di 




push 

ds 




push 

es 




mov 

cx, 

OFFSET bio_dat 

; bios data segment 


mov 

ds, 

cx 


ASSUME 

DS: 

MBDAT 



1 es 

di, 

disp1ay_ptr 



mov 

ah, 

attrib 



mov 

al , 

, , 



mov 

cx, 

80 * 25 



c 1 d 





rep stosw 




xor 

dx, 

cx 



mov 

cursor, dx 



cal 1 

wr_ 

cursor 



pop 

es 




pop 

ds 




pop 

di 




pop 

dx 




pop 

cx 




I ret 





INT 31 

Reset processor 


sw_reset 

PROC 

FAR 



WR.DEVICE DEV_RTC,0Fh,0 

; write SHUTDOWN code to RTC 


mov 

al, 0FEh 

; HW SHUTDOWN 


out 

64h, al 

; HW STATUS 

halt: 

hit 




jmp 

halt 


sw_reset 

ENDP 




ENDSEG 

BIOS 



PAGE 



; FAULT HANDLERS 




; In this prototype system, all the fault handler does Is to display 
; the name and location of the fault on the screen for a short period 

; of time before resetting the system. This should provide the user 

; with enough Information to correct the problem. 

; TSS for #DF - double fault handler 

; #DF must have Its own task to prevent shutdown 

SSEG FTASK8.TSS.0 


[continued) 
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DW 

0 

DW 

0, 0 

DW 

0, 0 

DW 

0, 0 

DW 

fau1t_ts 

DW 

0 

DW 

4 DUP (0) 

DW 

fhand1er_stack 

DW 

fhand1er_stack 

DW 

msg_08, 0 

GDT_SEL 

xtra8,0 

GDT_SEL 

fhand1er,0 

GDT_SEL 

fau1t_dat,0 

GDT_SEL 

fau1t_dat,0 

DW 

0 

ENDSEG 

FTASK8 


back link 

SS0:SP - unneeded/CPL-0 
SSI:SP 
SS2:SP 
IP 

flogs 

AX/CX/DX/BX 

SP 

BP 

SI/DI 

ES 

CS 

SS 

DS 

LDT selector 


; TSS for #TF - task fault handler 
; #TF must have Its own task to ensure 
SSEG FTASK10.TSS.0 

DW 0 

DW 0,0 

DW 0,0 

DW 0, 0 

DW fault_ts 

DW 0 

DW 4 DUP (0) 

DW fhandIer_stack 

DW fhandIer_stack 

DW msg_10, 0 

GDT_SEL xtra10,0 
GDT_SEL fhandIer,0 
GDT_SEL fauIt_dat,0 
GDT_SEL fault_dat,0 
DW 0 

ENDSEG FTASK10 


valid machIne state 
; back I Ink 

; SS0:SP - unneeded/CPL«0 
; SSI:SP 
; SS2:SP 
; IP 
; flags 
; AX/CX/DX/BX 
; SP 
; BP 
; SI/DI 
; ES 
; CS 
; SS 
; DS 

; LDT selector 


; TSS for #SF - stack fault handler 
; #SF requires Its own task to prevent #DF 
SSEG FTASK12.TSS,0 
DW 0 

DW 0, 0 

DW 0,0 

DW 0,0 

DW fault_ts 

DW 0 

DW 4 DUP (0) 

DW fhand Ier_stack 

DW fhand Ier_stack 

DW msg_12, 0 

GDT.SEL xtra12,0 
GDT_SEL fhandler,© 

GDT_SEL fauIt_dat,0 
GDT_$EL fault_dat,0 
DW 0 

ENDSEG FTASK12 


In certain occasions 
; back link 

; SS0:SP - unneeded/CPL«0 
; SSI:SP 
; SS2:SP 
; IP 
; flags 
; AX/CX/DX/BX 
; SP 
; BP 
; SI/DI 
; ES 
; CS 
; SS 
; DS 

; LDT selector 



MSEG 

FDAT.RD WR,0 

; Data for 

fault handlers 

msg_00 

DB 

"*** DIVIDE FAULT *»*", 0 

msg__01 

DB 

"*** SINGLE STEP TRAP ***“, 0 

msg_02 

DB 

••*** NMI ***", 0 

msg_03 

DB 

"*** INT 3 ***“, 0 

msg_04 

DB 

"*** OVERFLOW EXCEPTION ***“, 0 

msg_05 

DB 

"*** BOUND EXCEPTION ***", 0 

msg_06 

DB 

•'*** UNDEFINED OPCODE ***", 0 

msg_07 

DB 

"*** 287 NOT AVAILABLE ***", 0 

msg_08 

DB 

"*** DOUBLE FAULT ***", 0 

msg_09 

DB 

“*** 287 SEGMENT OVERRUN *** n , 0 

msg_10 

DB 

••*** ILLEGAL TSS FAULT ***", 0 

msg_11 

DB 

"*** NOT PRESENT FAULT ***“, 0 

msg_12 

DB 

"*** STACK FAULT ***", 0 

msg_13 

DB 

"*** GENERAL PROTECTION FAULT ***" 

msg_16 

DB 

"*** 287 EXCEPTION ***", 0 

msg_fcode 

DB 

"*** Fault code = ",0 

msg_faddr 

DB 

"*** Fault address = ",0 
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msg.unknown 
msg.buffer 

DB 

DB 

"*** UNKNOWN EXCEPTION 
40 DUP (0) 

fhand 1er.stack 

ALIGN 

DW 

LABEL 

2 

64 DUP (0) 

WORD 


ENDSEG 

FDAT 

; Code for fau 

MSEG HAND,EXONLY,0 

It handlers 

ASSUME CS:HAND, DS:FDAT 

fault_00: 

mov 

jmp 

si, OFFSET msg_00 
fai 1 

fau1t_01: 

mov 

jmp 

si, OFFSET msg 01 
fai 1 

fau1t_02: 

mov 

jmp 

si, OFFSET msg.02 
fai 1 

fau1t.03: 

mov 

jmp 

si, OFFSET msg_03 
fail 

fau1t.04: 

mov 

jmp 

si, OFFSET msg_04 
fai 1 

fau1t_05: 

mov 

jmp 

si, OFFSET msg_05 
fai 1 

fau1t_06: 

mov 

jmp 

si, OFFSET msg_06 
fai 1 

fau1t.07: 

mov 

jmp 

si, OFFSET msg.07 
fail 

fau1t_08: 

mov 

Jmp 

si, OFFSET msg_08 
fai 1 

fau1t_09: 

mov 

jmp 

si, OFFSET msg.09 
fai 1 

fau1t_10: 

mov 

jmp 

si, OFFSET msg.10 
fai 1 

fault.11: 

mov 

jmp 

si, OFFSET msg.11 
fai 1 

fau1t_12: 

mov 

jmp 

si, OFFSET msg.12 
fai 1 

fau1t_13: 

mov 

jmp 

si, OFFSET msg.13 
fai 1 

fau1t_16: 

mov 

jmp 

si, OFFSET msg.16 
fai 1 

unknown: 

mov 

jmp 

si, OFFSET msg.unknown 
fai 1 


; All fault handlers that have a task switch come 
fauIt.ts: 

pop ax 

mov bx, ES:[back.lInk] 

lar dx, bx 

Jnz fake.data 

test dh, 80h 

Jz fake_data 

and dh, 1Fh 

cmp dh, TSS.BUSY 

Jne fake.data 

Is I dx, bx 

cmp dx, TSS.LIMIT 

Jb fake.data 


"• 0 


force stack to word boundary 


here 

error code 

selector of faulting task 
check if accessable 
Invalid 

check present bit 
invaIid 

mask - leaving type Info 
should point to user TSS 
invalid 

get segment size 
ensure size OK 
branch too smaI I 

( continued) 
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At this point, we know that the back link points to a 
valid TSS, we now wish to create a readable data segment 
that points to the same physical location as the TSS so 
we can extract some Information from it. Since this segment 
is created pointing to the same address as a previously 
existing segment, it is called an ALIAS 


mov di, OFFSET falias 

mov dx, OFFSET int15_gdt_dat 

mov es, dx 

and bx, 0FFF8h 

mov cx, ES:[bx].phys_addr_lo 

mov ES:[di].phys_addr_lo. cx 

mov cl, ES:[bxJ.phys_addr_hi 

mov ES:[di1.phys_addr_hI, cl 

mov ES:[d!J.limit, TSS.LIMIT 

mov es, di 

push ES:[rCS] 

push ES:[r IP] 

push ax 

jmp fail 


offset of free descriptor 
selector for GDT as 
If it were a data seg 
convert selector to offset 
get phys addr of user TSS 
store in free descriptor 
continue with high byte 

complete free descriptor 
use as selector to segment 
push task’s CS 
push task’s IP 
error code 


fake_data: 


push WORD PTR 0FFFFh 

push WORD PTR 0FFFEh 

push ax 

jmp fail 


can't get real info 
push false CS, IP 
error code 


pause 

ploop: 


pause 


PROC NEAR 

mov bx, 10 

mov cx, 0FFFFh 

loop $ 

dec bx 

jnz ploop 

ret 
ENDP 


fail: mov 

mov 
mov 
mov 
mov 
int 
mov 
int 
mov 
mov 
int 
; check 
cmp 
Je 
cmp 
je 
cmp 
je 
cmp 
je 
cmp 
jne 

show_code: mov 

mov 
int 
pop 
mov 
mov 

CALL_EX 

mov 

mov 

int 

mov 

mov 

int 

show_addr: 

mov 

mov 

int 


ax, OFFSET fault_dat 
ds, ax 
es, ax 
dx, 0 

ah, MBIOS_WR_CRSR 
30h 

ah, MBIOS_WR_STRING 
30h 

dx, 0100h 

ah, MBIOS_WR_CRSR 

30h 

if error code on stack 

si, OFFSET msg_08 

show_code 

si, OFFSET msg_10 

show_code 

si, OFFSET msg_11 

show_code 

si, OFFSET msg_12 

show_code 

si, OFFSET msg_13 

show_addr 

si, OFFSET msg_fcode 
ah, MBIOS_WR_STRING 
30h 
dx 

di, OFFSET msg_buffer 
ah, LIB_BIN_HEX 
share_gate,0 
si, OFFSET msg_buffer 
ah, MBIOS_WR_STRING 
30h 

dx, 0200h 

ah, MBIOS_WR_CRSR 

30h 

si, OFFSET msg_faddr 
ah, MBI0S_WR_STRING 
30h 


; get legal DS 

; cursor x»0/y«0 
; home cursor 

; write msg 

; cursor x=0/y*1 
; home cursor 

; was DF fault? 

; was TF fault? 

; was NP fault? 

; was SF fault? 

; was GP fault? 

; print code message 

; get code from stack 
; convert to hex 
; and print 

; cursor x=0/y=2 
; home cursor 

; print addr message 
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pop 

bx 

; get offset 

pop 

dx 

; get segment 

push 

bx 

; save offset 

mov 

di, OFFSET msg_buffer 


mov 

ah, LIB_BIN_HEX 


CALL_EX 

share_gate,0 


mov 

si, OFFSET msg_buffer 


mov 

ah, MBIOS_WR_STRING 


i nt 

30h 


mov 

al, 


mov 

ah, MBIOS_WR_CHAR 


i nt 

30h 


pop 

dx 

; offset 

mov 

di, OFFSET msg_buffer 


mov 

ah, LIB_BIN_HEX 


CALL.EX 

share_gate,0 


mov 

si, OFFSET msg_buffer 


mov 

ah, MBIOS_WR_STRING 


int 

30h 


ca 1 1 

pause 

; wait 

ca 1 1 

pause 


cal 1 

pause 


mov 

ah, MBIOS_BELL 

; be 1 1 

int 

30h 


ca 1 1 

pause 


mov 

ah, MBIOS_BELL 

; bell 

int 

30h 


cal 1 

pause 


mov 

ah, MBIOS_BELL 

; bell 

int 

30h 


ca 1 1 

pause 

; wait 

ca 1 1 

pause 


cal 1 

pause 


ca 1 1 

pause 


Int 

31h 

; reset processor 

ENDSEG 

HAND 


PAGE 

MSEG 

SHLIB,EX_RO_CF,0 



This segment implements a library of shared functions that may be 
invoked through gate "share_gate". The segment is conforming, so its 
code will run at the same privelege as the caller. The calling 
sequence is merely to set up the registers and CALL the gate. If an 
illegal function number is called, the system Issues a DIVIDE BY 0. 


; Only registers 

BP, SP, CS. DS. ES, and 

SS are guaranteed preserved. 


ASSUME 

CS:SHLI8, DS:NOTHING, 

ES:NOTHING 

LIB SINT_BIN 

EQU 

0 


LIBJJINT.BIN 

EQU 

1 


LIB_HEX_BIN 

EQU 

2 


LIB_BIN_SINT 

EQU 

3 


LIB_BIN_UINT 

EQU 

4 


LIB_BIN_HEX 

EQU 

5 


sh1ib_code 

PROC 

cld 

FAR 

; set direction for string fns 


cmp 

ah, 5 

; beyond last function? 


jbe 

i ndex 

; no - do indexing 


xor 

ax, ax 

; zero ax 


di v 

a 1 

; force divide fault 

index: 

mov 

bl , ah 

; get FN code 


xor 

bh, bh 

; clear high order 


sh 1 

bx, 1 

; convert FN to index 


add 

bx, OFFSET table 



jmp 

WORD PTR CS:[bx] 

; invoke function. 

tab 1 e 

DW 

sint_bin 



DW 

ulnt_bin 



DW 

hex_bin 



DW 

bin_sint 



DW 

b1n_uin t 



DW 

bin.hex 



{continued) 
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Function 0 / ASCII SIGNED INT to BINARY conversion 
AH - 0 

DS:SI -> Null terminated string of digits 
Returns: 

AX <- 16-bit signed integer 



CY <- set 

If error 


sint_bin: 





mov 

cx, 10 

; multiply constant 


xor 

ax, ax 

; initialize accumulator 


xor 

dx, dx 



xor 

bh. bh 

; sign flag FALSE 


cmp 

BYTE PTR [si], 

; signed? 


jne 

get_schar 

; no 


i nc 

si 

; next char 


i nc 

bh 

; set signed flag 

get_schar: 

mov 

bl. [si] 

; get input character 


i nc 

s i 

; bump ptr 


or 

bl , bl 

; end of string? 


jz 

set_sign 



cmp 

bl, *0* 

; check valid 


jb 

err_ret 



cmp 

bl, *9* 



ja 

err_ret 



sub 

bl, *0* 

; convert digit to binary 


mu 1 

cx 

; decimal shift left 


odd 

al, bl 

; new digit 


adc 

ah, 0 

; propogate carry 


js 

err_ret 

; quit if sign overflow 


adc 

dx, 0 



jnz 

err_ret 

; quit if overflow 


jmp 

get_schar 


set_sign: 

or 

bh, bh 

; sign flag on 


jz 

done 

; no - return 


neg 

ax 

; else complement 

done: 

c 1 c 


; no error 


ret 



err_ret: 

stc 


; CY is error flag 


ret 



; Function 1 / ASCII UNSIGNED INT to 

BINARY conversion 

1 

AH « 1 



» 

DS:SI -> 

Null terminated string 

of digits 

; Returns: 



» 

AX <- 16- 

bit unsigned integer 


» 

CY <- set 

if error 


• 

uint_bin: 





mov 

CX, 10 

; multiply constant 


xor 

ax, ax 

; initialize accumulator 


xor 

dx, dx 


get_uchar: 

mov 

bl , [si] 

; get input character 


inc 

s i 

; bump ptr 


or 

bl, bl 

; end of string? 


jz 

done 

; yes - return 


cmp 

bl, *0* 

; check valid 


jb 

err_ret 



cmp 

bl, *9* 



ja 

err_ret 



sub 

bl, *0* 

; convert digit to binary 


mu 1 

cx 

; decimal shift left 


odd 

al , bl 

; new digit 


adc 

ah, 0 

; propogate carry 


adc 

dx, 0 



jnz 

err_ret 

; quit if overf1ow 


jmp 

get_uchar 



; Function 2 / ASCII HEX to BINARY conversion 

; AH - 2 

; DS:SI -> Null terminated string of digits 

; Returns: 

; AX <- 16-bit unsigned 

; CY <- set if error 

hex_bin: 
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xor 

Cl 

X 

CL 

X 

. 

init accumulator 

get_hchar: lodsb 


» 

get character 

or 

a 1 , a 1 

» 

last char? 

jnz 

test_hchars 



mov 

o 

X 

CL 

X 



ret 


; 

CY cleared by OR 

test__hchars: cmp 

a 1 , * 0 * 

» 

check valid digit 

jb 

err_ret 



cmp 

al, * 9* 



jbe 

got_va1Id 



or 

al . 20h 

; 

must be alpha - force lower 

cmp 

al, *a* 

; 

check valid char 

jb 

err_ret 



cmp 

al # f f • 



ja 

err_ret 



sub 

a 1 , 27h 

; 

adjust range 

got_valid: sub 

al, *0* 

; 

convert digit to binary 

cmp 

dx, 0FFFh 

; 

test overflow 

ja 

err_ret 



shl 

dx, 4 

; 

hex shift left 

add 

dl , al 

. 

insert new digit 

jmp 

get_hchar 


; FunctIon 3 / 

BINARY to ASCII SIGNED INT conversion 

; AH * 3 

; DX -> 16- 

bit signed 



; ES:DI -> 

Buffer for ascii string 



; Returns: 




; Null terminated ASCII string at ES 

: DI 


i 

bin_sint: test 

dh, 80h 

. 

sign bit? 

jz 

bin_uint 

» 

no - treat as unsigned 

mov 

al. 

» 

else write sign 

stosb 


neg 

dx 

• 

and complement 

jmp 

bin_uint 



div_tab DW 

10000 



DW 

1000 



DW 

100 



DW 

10 



DW 

1 



; Function 4 / BINARY to ASCII UNSIGNED 

INT 

conversion 

; AH = 4 

; DX -> 16- 

•bit unsigned 



; ES:DI -> 

Buffer for ascii string 



; Returns: 




; Null terminated ASCII string at ES 

: DI 


» 

bin_uint: mov 

si. OFFSET div.tab 


i ndex 

xor 

bx, bx 


bh is zero suppress flag 

mov 

ax, dx 


va 1 ue 

u_loop: cmp 

WORD PTR CS : [si ] , 1 


last divisor? 

j® 

u_out 


yes - output last digit 

xor 

dx. dx 


high order zero 

di v 

WORD PTR CS : [s i] 


DX:AX/10~n 

or 

ax, bx 


quotient »« 0 || 1 suppress? 

jz 

u_loop 


turn off zero suppress flag 

mov 

bh. 1 

. 

add 

al. * 0 * 

. 

quotient always single digit 

stosb 



mov 

o 

X 

CL 

X 

; 

restore AX with remainder 

i nc 

s i 



i nc 

si 

» 

next divisor 

jmp 

u_loop 



u_out: add 

al, * 0 * 

; 

last digit 

stosb 


xor 

a 1 . a 1 

• 

ASCII nul1 

stosb 



ret 




; Function 5 / BINARY to ASCII HEX conversi 

on 

; AH - 5 

; DX -> 16* 

-bit unsigned 




{continued) 
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ES:DI -> Buffer for ascM 
Returns: 

Null terminated 4 character ASCII string at ES:DI 


bin_hex: 

mov 

al , 

dh 


shr 

al , 

4 


add 

al , 

* 0 * 


cmp 

al. 

'9* 


jbe 

b I n Ji 1 

bin_h1: 

add 

stosb 

al , 

7 


mov 

al, 

dh 


and 

al , 

0Fh 


add 

al . 

* 0 * 


cmp 

al, 

*9* 


jbe 

bin. 

_h2 

bin_h2: 

add 

stosb 

al, 

7 


mov 

a 1, 

dl 


shr 

al . 

4 


add 

al , 

' 0' 


cmp 

al . 

'9' 


jbe 

bin. 

_h3 

bin_h3: 

add 

stosb 

al , 

7 


mov 

al , 

dl 


and 

al, 

0Fh 


add 

al, 

* 0 * 


cmp 

al. 

*9* 


jbe 

b 1 n. 

_h4 

b1n_h4: 

add 

stosb 

al. 

7 


xor 

stosb 

ret 

al, 

a 1 


; high order byte 
; high nybble 
; convert to ASCII 
; test value > ’9’ 

; ajust alpha 

; high order byte 
; low nybble 
; convert to ASCII 
; test value > *9* 

; ajust alpha 

; low order byte 
; high nybble 
; convert to ASCII 
; test value > ’9’ 

; ajust alpha 

; low order byte 
; low nybble 
; convert to ASCII 
; test value > *9’ 

; ajust alpha 


; ASCII null 


shlib_code ENDP 

ENDSEG SHLIB 


PAGE 


This section contains the main code and data. We come here initially 
in Real Address Mode, perform necessary setup, and enter Protected 
Virtual Address Mode. The data segment has combine type STACK 
so that the linker will initialize SS:SP. 

MSEG DSC,RD_WR,0,STACK 


no_pm_msg 

DB 

’*** Unable to 

b1ank_line 

DB 

80 DUP (’ •) 


DB 

0 

msg 

DB 

’Testing*,0 


ALIGN 

2 


DW 

100 DUP (?) 


ENDSEG 

DSC 


enter protected mode ***$» 


; force stack to word bound 
; stack 


SSEG INIT_TSS,TSS,0 

TSS_BLOCK <> ; uninitialized 

ENDSEG INIT_TSS 

MSEG INIT,EXONLY,0 

ASSUME CS:INIT, DS:DSC 


adjust_addr PROC NEAR 

This subroutine marches through a descriptor table to fixup 16-bit 
segment addresses to full 24-bit physical addresses. Since the 
segment fixups were done by the DOS linker in Real Address Mode, 
all we need to do is multiply by 16. We assume the high order 8 
bits are zero, i.e., all addresses are in the first 1Mb. 

Called with ES:0 pointing to table, CX is number of entries. 

xor bx, bx ; initial offset 

1: mov a, » ES:[bx].access ; get access rights byte 

test al, 10h ; is descriptor a segment? 

jnz got_seg ; yes 
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and 

a 1 , 

0Fh 

; 

extract type 


cmp 

al , 

3 

» 

gate? 


Ja 

update_next 

* 

yes - skip segment adjust 

got_seg: 

mov 

ax, 

ES: [bx].phys_addr. 

Jo; 

get segment 

mov 

dx, 

16 




mu 1 

dx 


; 

convert to phys addr 


mov 

ES: 

[bxl.phys_addrJ o, 
[bx J.phys_addr_hi, 

ax; 

store 


mov 

ES: 

dl; 

24 bits 

update_next: 

add 

bx, 

8 

> 

Incr to next descrip 

loop 

11 





ret 





adjust_addr 

ENDP 





start: 

mov 

ax, 

DSC 

» 

set up DS 


mov 

ds, 

ax 




sti 






When DOS created the prototype descriptors, it placed segment addresses 
In the physical address portion of the segment descriptors. We must 
fix up all descirptor tables which contain segment descriptors. 


mov 

ax, T2LDT 


mov 

es, ax 

; point to proto LDT 

mov 

cx, 121dt_1imit 

; get limit 

i nc 

cx 

; bump to size in bytes 

shr 

cx, 3 

; convert to # entries 

ca 1 1 

adjust_addr 


mov 

ax, GDT 


mov 

es, ax 

; point to proto GDT 

mov 

cx, gdtJimit 


inc 

cx 


shr 

cx, 3 

; gdt entries 

ca 1 1 

adjust_addr 



Now we ask the BIOS to place us in protected mode. The BIOS requires 
the first 7 descriptors of the GDT to be setup as we have done. This 
gives it enough information to load GDTR and IDTR and setup a new 
code and data segment for the calling routine. The BIOS will also 
program the 8259A to our requested interrupt vectors. Additionally, it 
sets up the internal AT hardware to allow addresses > 1Mb to go out 
over the bus (frees A20 line). 


xor 

si, si 

ES:SI -> proto GDT 


mov 

bh, 20h 

int level 1 start 


mov 

bl. 28h 

int level 2 start 


mov 

ah, 89h 

enter PM request 


mov 

cx, 0FFFFh 

idle here to ensure 

al 1 

loop 

$ 

DOS keybd ints processed 

i nt 

15h 

BIOS cal 1 


jnc 

vm 

successfu1 if no CY 

bit 

mov 

mov 

int 

ah, 9 

dx, OFFSET no_pm_msg 

21 h 

; no - print message 


mov 

ax, 4C01h 

; failure 


int 

21 h 

; exit 



;;; NOW IN PROCTED MODE 

— 

INTS DISABLED 


vm: 

mov 

bp, 

sp 

; setup registers 


mov 

ax, 

ds 



mov 

es, 

ax 



mov 

ax, 

OFFSET setup_tss 

; active task 

pmjn i t_done: 

Itr 

ax 



mov 

ah, 

MBIOS.BELL 

; bell 


int 

30h 




cal 1 

Idle 



mov 

ah, 

MBIOS.CLS 

; c 1 s 


int 

30h 




[continued) 
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; Enable Ints 

xor al, al ; no Ints masked 

out MASTER+1, a I 

out SLAVE+1, a I 

stl 

; Print number of ticks so far 
prlnt_tIcks: 

mov ah, MBIO$_CLS ; clear screen 

Int 30h 

mov dx, 0010h 

mov ah. MBIOS_WR_CRSR 

Int 30h 

mov ax, OFFSET bio_dat 

mov es, ax 

cl I 

mov dx, WORD PTR ES:tlck_ctr ; get tick counter 

mov ax, WORD PTR ES:tick_ctr[2] 

st I 

push dx 



ca 1 1 

pr_hex__word 

» 

print high order 



pop 

ax 





cal 1 

pr_hex_word 

» 

print low order 



cal 1 

idle 

• 

pause 



CALL.EX 

task2_tss,0 

» 

invoke task 2 



ca 1 1 

idle 





cal 1 

idle 





mov 

ah, MBIOS_BELL 

» 

be 1 1 



Int 

30h 





jmp 

prlnt_ticks 

• 

loop forever 


idle 

PROC 

NEAR 





push 

bx 





push 

cx 





mov 

bx, 10 




iloop: 

mov 

cx, 0FFFFh 





loop 

$ 





dec 

bx 





jnz 

1 loop 





pop 

cx 





pop 

bx 





ret 





idle 

ENDP 





pr_hex_word 

PROC 





; Print word in AX 





push 

bp 





mov 

bp, sp 





sub 

sp. 10 

• 

space for string 

on stack 


push 

ds 





pop 

es 

; 

es = ds 



1 ea 

di, [bp-10] 

; 

destination 



mov 

dx, ax 

• 

va 1 ue 



mov 

ah, LIB_BINJHEX 

? 

function 



CALL_EX 

share_gate,0 

» 

shared code 



1 ea 

si, [bp-10] 

i 

hex string ptr 



mov 

ah, MBI0S_WR_STRING 

• 

function 



Int 

30h 

* 

print string 



mov 

sp, bp 





pop 

bp 





ret 





pr_hex_word 

ENDP 






ENDSEG 

INIT 





PAGE 





; Finally 

, we have a small second task, 

which will a 1ternate 

execution 


; with the initial task. It runs at privelege level 3, which means it 

; has access only to Its code segment, data segment, the shared library 

; gate and INT 30h. 

SSEG T2LDT,LDT,0 

; All memory segments for this task reside in a local descriptor table. 
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DSCRP 

task2 cs 

.C0DE2 

CS for 2nd task 


DSCRP 

tosk2_dsc.DSC2 

DS/SS for 2nd task 


DSCRP 

tosk2_stk0,STK2_0 

Level 0 stack for OS calls 



ENDSEG 

T2LDT 




SSEG 

TASK2.TSS,0 




DW 

0 

back 1ink 



DW 

STK2_0_limit + 1 

SP0 



LDT_SEL 

task2_stk0,0 

SS0 



DW 

0, 0 

SSI:SP 



DW 

0, 0 

SS2:SP 



DW 

top 

initial IP 



DW 

0 

f 1 ags 



DW 

4 DUP (0) 

AX/CX/DX/BX 



DW 

stack2 

SP 



DW 

stack2 

BP 



DW 

2 DUP (0) 

SI/DI 



LDT.SEL 

task2_dsc,3 

ES - segments all in LDT 



LDT_SEL 

task2_cs,3 

CS 



LDT_SEL 

task2_dsc,3 

SS 



LDT_SEL 

task2_dsc,3 

DS 



GDT.SEL 

task2_ldt.0 

LDT selector 



ENDSEG 

TASK2 




MSEG 

STK2_0,RD_WR,0 




DW 

128 DUP (?) 

; stack for level 0 execution 



ENDSEG 

STK2_0 




MSEG 

DSC2,RD_WR,3 


; Data 

and stack segment for 2nd task 


t2_msg 


DB 

"Task 2 running",0 




ALIGN 

2 

; stack on word boundary 



DW 

128 DUP (?) 


stack2 


LABEL 

WORD 




ENDSEG 

DSC2 




MSEG 

C0DE2.EX0NLY.3 


top: 


ASSUME 

CS:C0DE2, DS:DSC2 

; task starts here first time 


mov 

dx, 0032h 




mov 

ah, MBIOS_WR_CRSR 




int 

30h 

; cursor to "safe" location 



mov 

si. OFFSET t2_msg 




mov 

ah, MBIOS_WR_STRING 




int 

30h 

; print message 



1 ret 


; return to previous task 



Jmp 

top 

; when task invoked again, 

; CS:IP points here (after IRET) 



ENDSEG 

C0DE2 




END 

start 



PROTECT.INC 

"A Protected-Mode Program for the PC AT," by Ross 
P. Nelson. Inside the IBM PCs, Extra Edition, page 123. 


. 286C 
.SALL 
.XLIST 


*;ThIs file provides macros to simulate PM286 Instructions not 
•.supported by MASM V2.0. Some macros do simple operand checking, but 
; 11 is possible to generate illegal instructions if you aren't 
jcareful. The opcodes simulated are: 


ARPL 

CLTS 

LAR 

LGDT 

LIDT 

LLDT 

LMSW 

LSL 

LTR 

SGDT 

SIDT 

SLOT 

SMSW 

STR 

VERR 


(continued) 
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arp I 


cits 


I ar 


I gdt 


I idt 


I Idt 


Imsw 


VERW 


MACRO 

ew, rw 

LOCAL 

start, end 

start ■ 

$ 

IFDEF 

ew 

add 

WORD PTR ew, 

ELSE 


add 

ew, rw 

ENDIF 


end - $ 


ORG 

start 

DB 

63h 

ORG 

end 

ENDM 


MACRO 


DB 

0Fh, 06h 

ENDM 


MACRO 

rw, ew 

LOCAL 

start, end 

DB 

0Fh 

start ■ 

$ 

add 

rw, ew 

end ■ $ 


ORG 

start 

DB 

02h 

ORG 

end 

ENDM 


MACRO 

mem 

DB 

0Fh 

add 

WORD PTR mem 

ENDM 


MACRO 

mem 

DB 

0Fh 

add 

WORD PTR mem 

ENDM 


MACRO 

ew 

LOCAL 

start, end 

DB 

0Fh 

start « 

$ 

rc 1 

ew, 1 

end * $ 


ORG 

start 

DB 

0 

ORG 

end 

ENDM 


MACRO 

ew 

LOCAL 

start, end 

DB 

0Fh 

start « 

$ 

d 1 v 

ew 

end ■ $ 


ORG 

start 

DB 

1 

ORG 

end 

ENDM 



;; ADJUST RPL 

li is ew defined symbol? 
rw 

;; assume ew Is register 


;; CLEAR TS BIT 

;; LOAD ACCESS RIGHTS 


;; LOAD GDT REGISTER 
. dx 

;; LOAD IDT REGISTER 
, bx 

;; LOAD LDT REGISTER 


;; LOAD MACHINE STATUS WORD 


I s I 


Itr 


MACRO rw, ew ;; LOAD SEGMENT LIMIT 

LOCAL start, end 

DB 0Fh 

start * $ 

add rw, ew 

end = $ 

ORG start 

DB 03h 

ORG end 

ENDM 

MACRO ew ;; LOAD TASK REGISTER 

LOCAL start, end 
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sgdt 


s i dt 


sldt 


smsw 


st r 


verr 


verw 


DB 

0Fh 



start * $ 




rcr 

ew, 1 



end * $ 




ORG 

start 



DB 

0 



ORG 

end 



ENDM 




MACRO 

mem »i 

STORE 

GDT REGISTER 

DB 

0Fh 



odd 

WORD PTR mem, 

ax 


ENDM 




MACRO 

mem $ i 

; STORE 

IDT REGISTER 

DB 

0Fh 



add 

WORD PTR mem, 

cx 


ENDM 




MACRO 

ew ;; 

; STORE 

LDT REGISTER 

LOCAL 

start, end 



DB 

0Fh 



start * $ 




rol 

ew, 1 



end - $ 




ORG 

start 



DB 

0 



ORG 

end 



ENDM 




MACRO 

ew ; 

; STORE 

MACHINE STATUS 

LOCAL 

start, end 



DB 

0Fh 



start * $ 




sh 1 

ew, 1 



end = $ 




ORG 

start 



DB 

1 



ORG 

end 



ENDM 




MACRO 

ew ; 

; STORE 

TASK REGISTER 

LOCAL 

start, end 




DB 

0Fh 

start 

« $ 

ror 

ew, 1 

end ■ 

$ 

ORG 

start 

DB 

0 

ORG 

end 

ENDM 


MACRO 

ew 

LOCAL 

start 

DB 

0Fh 

start 

- $ 

sh 1 

ew, 1 

end = 

$ 

ORG 

start 

DB 

0 

ORG 

end 

ENDM 


MACRO 

ew 

LOCAL 

start 

DB 

0Fh 

start 

* $ 

shr 

ew, 1 

end - 

$ 

ORG 

start 

DB 

0 

ORG 

end 

ENDM 



VERIFY READ ACCESS 


end 


VERIFY WRITE ACCESS 


end 
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This mocro must be used in place of the standard segment override 
in conJuction with the above macros. The standard segment override 
will be attached to the wrong portion of the instruction, e.g., ofter 
the 0Fh In an LGDT Instruction. 

DO NOT USE: 

LGDT ES:[my_gdt] 

CODE THIS INSTEAD: 


segov 


SEGOV 

ES 

LGDT 

[my_gdt] 

MACRO 

s 

IFIDN 

<s>,<ES> 

DB 

26h 

ENDIF 


IFIDN 

<s>,<CS> 

DB 

2Eh 

ENDIF 


IFIDN 

<8>.<SS> 

DB 

36h 

ENDIF 


IFIDN 

<s>,<DS> 

DB 

3Eh 

ENDIF 


ENDM 


.LIST 



seg override for 286 macros 


CSETS.LST 

"RAM-Loadable Character Sets for the IBM PC," by 
Richard Wilton. Inside the IBM PCs, Extra Edition, page 197. 


Listing 1 

210 DEFINT A-Z 

220 SCREEN 2 : CLS 

230 FOR I = 0 TO 3*80 STEP 80 

240 FOR S = &HB800 TO &HBA00 

250 DEF SEG = S 

260 READ B 

270 POKE I,B 

280 NEXT S 

290 NEXT 

300 PRINT : PRINT 

310 END 

320 • 


’ rows are 80 bytes apart 
STEP &H200 ’ even rows in B800 

' odd rows in BA00 

* store each byte into video buffer 


330 ’dot data which defines the character ’A* 

340 DATA &h18,&h3c,&h66,&h66,&h7e,&h66,&h66,&h66 


Listing 2. 


; definitions 
csdefs db 
db 
db 
db 


for 8 by 8 characters 80h through FFh 
087h,033h,03Fh,033h,087h,0E7h,0F3h,087h 
0FFh,099h,0FFh,099h,099h,099h,0C0h,0FFh 
0F1h,0FFh,0C3h,099h,081h,09Fh,0C3h,0FFh 
081h,03Ch,0C3h,0F9h,0C1h,099h,0C0h,0FFh 


080h 
081 h 
082h 
083h 


db 087h,093h,093h,093h,093h,0FFh,0FFh,0FFh 
db 08Fh,0E7h,0CFh,09Fh,087h,0FFh,0FFh,0FFh 
db 0FFh,0FFh,0C3h,0C3h,0C3h,0C3h,0FFh,OFFh 
db 0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh 


0FCh 

0FDh 

0FEh 

0FFh 


; put CGA into All Points Addressible graphics mode so that DOS will use 
; our character table 

mov a 1,6 ; 640x200 2color APA graphics 

mov ah,0 
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int 


10h 


point CGA graphics character generator to our character definitions 
dx,offset csdefs 
cs 


mov 

push 

pop 

mov 

mov 

int 


ds 

al , IFh 
ah,25h 
21h 


DS:DX points to our table 
interrupt number 
DOS function number 


Listing 3. 


• definitions for 8 by 8 characters 00h through FFh 
csdefs db 0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh 

db 081h,07Eh,05Ah,07Eh.042h,066h,07Eh,081h 

db 081h,000h,024h,000h.03Ch,018h,000h,081h 

db 093h.001h,001h,001h,083h,0C7h.0EFh,0FFh 


000h 
001h 
002h 
003h 


db 

db 

hi_ha If db 
db 


089h,023h,0FFh.0FFh,0FFh.0FFh,0FFh.0FFh 

0FFh,0EFh,0C7h,093h,039h,039h,001h,0FFh 
087h,033h,03Fh,033h,087h,0E7h,0F 3h,087h 
0FFh,099h,0FFh,099h,099h,099h,0C0h,0FFh 


07Eh 
07Fh 
080h 
081h 


db 087h,093h,093h,093h,093h,0FFh,0FFh,0FFh 
db 08Fh,0E7h,0CFh,09Fh,087h,0FFh,0FFh,0FFh 
db 0FFh,0FFh,0C3h,0C3h,0C3h,0C3h,0FFh,0FFh 
db 0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh 


0FCh 

0FDh 

0FEh 

0FFh 


; put EGA into All Points Addressible graphics mode so that DOS will use 
; our character table 

; 640x200 2color APA graphics 


mov 

al ,6 

mov 

ah ,0 

int 

10h 

EGA graphics character g 

mov 

bp,offset csdefs 

push 

cs 

pop 

es 

mov 

b* ,0 

mov 

d1,19h 

mov 

al,21h 

mov 

ah, 11h 

int 

10h 


ES:BP points to our table 
BK := 0y(B§06hwrdi<fcte6eiBLUbte 
number of rows on screen) 

DL := 25 (number of character rows 
on screen) 

"user graphics character load" 

BIOS "character generator routine" 
cal I EGA BIOS 


Listing 4 


csdefs 


mov 

bp,offset h1_ha 1f 

push 

cs 

pop 

es 

mov 

al,20h 

mov 

ah, 11h 

i nt 

10h 

4. 

t i ons 

for 8 by 8 characters 

db 

0FFh,0FFh.0FFh,0FFh 

db 

081h,07Eh,05Ah,07Eh 

db 

081h.000h.024h.000h 

db 

093h.001h.001h.001h 


; ES:BP -> 2nd half of table 
; "int IFh load" 


000h 
001h 
002h 
003h 


db 087h,093h,093h,093h,093h,0FFh,0FFh,0FFh 
db 08Fh,0E7h, 0CFh,09Fh, 087h, 0FFh,0FFh, 0FFh 
db 0FFh,0FFh,0C3h,0C3h,0C3h,0C3h,0FFh,0FFh 
db 0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh 


0FCh 

0FDh 

0FEh 

0FFh 
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; call BIOS to copy our definitions into 

; bit pi one 2 

mov 

bp,offset csdefs 

push 

cs 

pop 

es 

mov 

cx,256 

mov 

dx ,0 

mov 

bl ,0 

mov 

bh ,8 

£ mov 

aHi,10h 

int 

10h 

; update BIOS 

RAM area in segment 40h 

mov 

ax,40h 

mov 

ds, ax 

mov 

word ptr ds:[4Ah],80 

mov 

word ptr ds:[4Ch],1C00h 

Listing 5. 

csdefs db 

000h,000h,000h,000h.000h, 

£ db 

07Bbp00)h,0A5h.081h,0BDh, 

db 

8 dup(0) 

db 

07Eh,0FFh,0DBh.0FFh,0C3h, 

db 

8 dup(0) 

db 

070h,018h,030h,060h,078h, 

db 

8 dup(0) 

db 

000h,000h.03Ch,03Ch,03Ch. 

db 

8 dup(0) 

db 

000h,000h,000h,000h,000h, 

db 

8 dup(0) 

; set configuration switch on HGC Plus 

mov 

dx,3BFh ; 

mov 

al .1 ; 

out 

dx.ol ; 

; copy character definition table to B000 

mov 

ax,0B000h 

mov 

es, ax 

mov 

di,4000h . 

push 

cs 

pop 

ds 

mov 

si,offset csdefs ; 

mov 

CX,4096 ; 

rep 

movsb ; 

; Program the 

CRT controller to display 4 

; Characters are displayed in a 9x8 matri 

mov 

dx,3B4h ; 

mov 

si,offset regs00_0D ; 

mov 

cx.0Eh ; 

xor 

ah,ah ; 

Iabel2: mov 

a 1 ,ah 

out 

dx,a 1 • 


character generator RAM area in 


ES:BP points to our table 

CX :■ number of characters defined 

in table 

DX character offset in table 

BL number of table to load (must 
be 0-3) 

BH # bytes/character in table 

Bil©6r "aHiphacteadgenerator routine" 
cal I EGA BIOS 


update CRT_COLS (number of character 
columns on the display) 
update CRT_LEN (80 rows * 43 columns 
* 2 bytes/character, rounded up to 
next even IK boundary) 


000h 
001h 

002h 


; 0FDh 
; 0FEh 
; 0FFh 


i/o port address 
activate RAM from B000:0000 
through B000:7FFF 


; ES:DI :« B000:4000 

; DS:SI -> our character def table 


CRT controller register index port 

DS:SI -> start of table of register 
vaIues 

CX := loop counter 
AH := 0 (initial CRT controller 
register number) 

; store CRT controller index reg 
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1 odsb 


AL :« data for CRT controller reg 

1 nc 

dx 

DX := 3B5h (CRT data reg port) 

out 

dx, a 1 

store data to CRT controller reg 

dec 

dx 

DX :« 3B4h 

£ Inc 

ah 

AH :» next CRT controller index # 

1 oop 

1abe12 


mov 

a 1,14h ; 

xModeReg index number 

out 

dx,a 1 


1 odsb 

inc 

dx 


out 

dx,al ; 

; configure xModeReg for RAM character 


i 

set and proper character width 

; update BIOS 

RAM area in segment 40h 


mov 

ax,40h 


mov 

ds ,ax 


mov 

word ptr ds:[4Ahl,80 

update CRT_COLS (80 columns) 

mov 

word ptr ds:[4ChJ,1C00h 

update CRT_LEN (80 columns * 43 rows 
* 2 bytes/character, rounded up to 



even IK boundary) 

; table of CRT controller register values 

regs00_0D 

db 61h,50h,52h,0Fh 

; regs 0 - 3 (9 wide) 

db 2Dh,02h,2Bh,2Ch 

; regs 4 - 7 (8 high) 


db 02h.07h.06h.07h 

; regs 8 - 0Bh (scans/char, 

; cursor location) 


db 00h,00h 

; regs 0Ch - 0Dh (always zero) 

xModeReg 

db 01h 

; "4K RamFont", 9 dot wide 
; characters 

Listing 6. 

cset0 equ 

0 

; character generator RAM bank #’s 

csetl equ 

1 


; 1st 256 characters are 9x14 ROM characters (default for 350-line display) 

mov 

b 1 , cset0 

; indicate bank 0 of char generator RA> 
; (A000:0000 in bit plane 2) 

mov 

al ,1 

; indicate 8x14 ROM characters 

mov 

ah.llh 


int 

10h 

; call BIOS to load character table 

; 2nd 256 characters are 8x8 ROM character set 

mov 

b 1 , csetl 

; indicate bank 1 of char gen RAM 
; (A000:4000 in bit plane 2) 

mov 

al ,2 

; indicate 8x8 ROM characters 

mov 

ah.llh 


int 

10h 


; Enable attribute bit 3 selection of character set 

mov 

bl,(csetl shl 2)+cset0 

; BL :■ value for Sequencer Character 
; Map Select register 

mov 

al ,3 

; "set block specifier" 

mov 

ah.llh 


Int 

10h 

; call BIOS to program Sequencer 

; Disable bit 

3 of attribute byte for palette selection 

mov 

bh ,7 

; bit mask 

mov 

bl,12h 

; Attribute Controller: Color Plane 
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al ,0 


; Enable register number 


mov 


; "individual palette register" 


mov 

ah,10h 



Int 

10h 


; call BIOS to set register 

; Display a message 




push 

cs 




pop 

ds 




mov 

s I .offset 

csmsg0 



mov 

bl ,7 


; bit 3 of attribute ■ 0 


mov 

cx,25 


; length of string 

£ 

ca 1 1 

show 


; display string using char set 


mov 

si.offset 

csmsgl 



mov 

bl,0Fh 

; bit 3 of attribute ■ 1 


mov 

cx.25 




cal 1 

show 

• 

; display string using char set 

; Subroutine 

which displays a string 

using a given attribute 

show 

proc 

near 


; Caller: DS:SI -> string 


Jcxz 



; CX * length of i 

; BL * attribute 


show2 



showl: 

lodsb 



; AL :* next char 


push 

cx 




push 

bx 




ca 1 1 

emit 


; display this character 


pop 

bx 



pop 

cx 




loop 

showl 



show2: 

ret 




show 

endp 





; Subroutine which displays a single character using a given attribute 


emi t 

proc 

near 

; Caller: AL = character 




; BL * attribute 




; Returns: nothing, but advances 




; the cursor 


push 

bx 



push 

cx 



cmp 

a 1.20h 



jb 

emi 11 

; jump if control character 


push 

ax 

; save char on stack 


mov 

cx. 1 

; CX :* § of chars to write 


mov 

bh, 0 

; BH :«* video display page 0 


mov 

ah, 9 

; call BIOS to write attribute and 


int 

10h 

; character at cursor 


pop 

ax 

; AL :* character 

emlt1: 

mov 

ah,0Eh 

; call BIOS to rewrite character in 


int 

10h 

; "teletype mode" which advances 
; the cursor 

£ 

pop 

bx 



ret 



emi t 

endp 



; Strings to be 

disp1ayed 


csmsg0 

db 

'This is character 

set 0',0Dh,0Ah 

csmsgl 

db 

'This is character 

set 1\0Dh,0Ah 


268 BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 






IBM 


Listing 7. 


; set configuration switch on HGC Plus 


Iabel0: mov 

dx,3BFh ; 

i/o port address 

mov 

a 1 ,1 ; 

activate RAM from B000:0000 

out 

dx,al ; 

through B000:7FFF 

; Copy 1st 256 

character definitions into 

character generator RAM from BIOS ROM 

mov 

ax,0F000h 


mov 

ds, ax 


mov 

si,0FA6Eh ; 

DS:SI -> start of 8x8 character 


» 

definition table in ROM 

mov 

ax,0B000h 


mov 

es , ax 


£ mov 

di,4000h ; 

E8eDIn+>ieibactoo6gHeacedies font 

xor 

a 1 , a 1 ; 

AL := zero byte (used for padding) 

mov 

cx,256 ; 

CX := # of characters in table 

labell: push 

cx ; 

preserve loop counter 

mov 

cx,8 ; 

CX := # of bytes in one character 


t 

definition 

rep 

movsb ; 

copy to HGC font storage area 

mov 

cx ,8 ; 

CX :» # of bytes of padding 

rep 

stosb ; 

store zeroes 

pop 

cx ; 

loop across all 256 characters 

loop 

1abe11 


; Copy 2nd 256 

character definitions into 

character generator RAM 

mov 

ax,0B000h 


mov 

ds ,ax 


mov 

s1,4000h ; 

DS:SI -> start of 8x8 character 


; 

definition table in HGC Plus RAM 

mov 

cx,256*16 ; 

CX := size of 256-character table 

Iabel2: lodsb 

; 

copy "reverse" of 1st 256 chars ... 

not 

a 1 


stosb 

» 

.. into table for 2nd 256 chars 

loop 

label 2 


; Program the 

CRT controller to display 25 lines of 8 by 14 characters. 

mov 

dx,3B4h ; 

CRT controller register index port 

push 

cs 


pop 

ds 


mov 

si,offset regs00_0D ; 

DS:$I -> start of table of register 


• 

va1ues 

mov 

cx,0Eh ; 

CX := loop counter 

xor 

ah,ah ; 

AH :* 0 (initial CRT controller 


• 

register number) 

1obe13: mov 

a 1 ,ah 


out 

dx,al ; 

store CRT controller index reg 

1 odsb 

; 

AL :* data for CRT controller reg 

1 nc 

dx ; 

DX 3B5h (CRT data reg port) 

out 

dx,a 1 ; 

store data to CRT controller reg 

dec 

dx ; 

DX :« 3B4h 

i nc 

ah ; 

AH := next CRT controller Index # 

loop 

1abe13 


mov 

cx ,3 


mov 

ah,14h 

index value for xModeReg 

£abel4: oat 

d* , a Hi ; 

Samee$eops6drw4*lbrexCBi!idedntcol ler . 

lodsb 

• 

.. character set 

1 nc 

dx 


out 

dx, a 1 


dec 

dx 
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i nc ah 

loop Iabel4 


Update BIOS 
mov 
mov 
mov 
mov 


RAM area In segment 40h 
ax,40h 
ds , ax 

word ptr ds:T4Ahl.90 
word ptr ds:[4Ch],1400h 


Display a 

message 

push 

cs 

pop 

ds 

mov 

dx,1859h 

mov 

cx, 0 

mov 

bh, 0 

mov 

ax,600h 

int 

10h 


CRT_COLS 90 

CRTJ.EN :* 90 columns * 25 rows 
* 2 bytes/char, rounded up to next 
higher IK 


use BIOS scroll routine ... 

.. to set attribute bytes in .. 
.. display buffer to zero 


mov si.offset csmsg0 

mov bl.0 

mov cx,48 

caI I show 


1st message 

BL (high nibble) := 0 (normal attrib) 
BL (low nibble) :« 0 (1st 256 chars) 
length of string 
display string using char set 0 


mov 

si.offset csmsgl 

; 2nd message 



mov 

bl,81h 

; BL (hi nibble) 

:= 8 ( 

'intense video) 



; BL (lo nibble) 

1 ( 

[2nd 256 chars) 

mov 

cx,49 




cal 1 

show 

; display str ing 

us i ng 

char set 1 


; Subroutine whi 

ch displays 

a string using a given attribute 

show 

proc 

near 

; Caller: DS:SI -> string 


Jcxz 

show2 

; CX « length of string 

; BL » attribute 

showl: 

lodsb 


; AL := next char 


ca 1 1 
loop 

em i t 
showl 

; display this character 

show2: 

ret 



show 

endp 




; Subroutine which displays a single character using a given attribute 
; Bits 0-3 of the attribute byte and bits 0-7 of the character form an 
; 12-bit extended character code. Bits 4-7 of the attribute byte determine 
; the actual attribute displayed. 


proc 

near 

; Caller: AL = character 

; BL * attribute 

; Returns: nothing, but advances 

; the cursor 

push 

bx 


push 

cx 


cmp 

a 1,20h 


jb 

emi 11 

; jump if control character 

push 

ax 

; save char on stack 

mov 

cx, 1 

; CX :*= § of chars to write 

mov 

bh, 0 

; BH := video display page 0 

mov 

ah, 9 

; call BIOS to write attribute and 

int 

10h 

; character at cursor 

pop 

ax 

; AL :*= character 
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emitl: mov 

ah,0Eh 

» 

call BIOS to rewrite character in 

int 

10h 

• 

• 

"teletype mode" which advances 
the cursor 

pop 

cx 



pop 

bx 



ret 




£mit endp 




; table of CRT 

controller register values 


regs00_0D 

db 

6Dh,5Ah,5Ch,0Fh 

; regs 0 - 3 (8 wide) 

db 

19h,06h,19h,19h 

; regs 4-7 (14 high) 


db 

02h.0Dh.0Ch.0Oh 

; regs 8 - 0Bh (scans/char, 

; cursor location) 


db 

00h,00h 

; regs 0Ch - 0Dh (always zero) 

xModeReg 

db 

07h 

; "48K RamFont", 8 dot wide 



; characters 

ScoreReg 

db 

0Dh 

; underscore reg 

StrikeReg 

db 

06h 

; overstrike reg 

; Strings to be displayed 


csmsg0 db 

'These 

characters are in 

the first group of 256’,0Dh,0Ah 

csmsgl db 

'These 

characters are in 

the second group of 256’,0Dh,0Ah 

KeyMsg db 

0Dh,0Ah,'Press any key to 

continue ...',0Dh,0Ah 

CSLS1.LST 




"RAM-Loadab1e 

Character 

Sets for the IBM 

PC," by 

Richard Wi1 ton 

. Inside 

the IBM PCs, Extra 

Edition, page 197. 


100 

’RAM-Loadable Character Sets on 

the IBM 

PC 

110 

'Listing 1 



120 

» 



130 

’Richard Wi1 ton 



140 

'July 1986 



150 

• 



160 

’Notes: 



170 

' This program demonstrates a 

rudimentary "software character generator 

180 

’ for All Points Addressible 

graphics 

modes on IBM’s Color Graphics 

190 

* Adapter (CGA). 



200 

i 



210 

DEFINT A-Z 



220 

SCREEN 2 : CLS 



230 

FOR I - 0 TO 3*80 STEP 80 

' 

rows are 80 bytes apart 

240 

FOR S - &HB800 TO &HBA00 STEP 

&H200 ' 

even rows in B800, odd in BA00 

250 

DEF SEG =■ S 



260 

READ B 



270 

POKE I.B 

» 

store each byte into video buffer 

280 

NEXT S 



290 

NEXT 




300 PRINT : PRINT 
310 END 
320 1 

330 ’dot data which defines the character *A’ ... 
340 DATA &h18,&h3c,&h66,&h66,&h7e,8ch66 ,&h66 ,&h66 


CSLS2.ASM 

"RAM-Loadable Character Sets for the IBM PC," by 
Richard Wilton. Inside the IBM PCs, Extra Edition, page 197. 


title '128-character table for CGA' 
name csls2 

page 55,132 


( continued ) 


BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER 1986 271 









IBM 


RAM-Loadable Character Sets for the IBM PC 
Listing 2 

Richard WiI ton 
July 1986 


Notes: 

This program loads a 128-charocter definition table for use in APA 
graphics modes. The program first selects on APA graphics mode. 
Then the BIOS pointers to the character set table ore updated. 

Use on IBM Color Graphics Adopter ONLY. 


cseg segment para public ’CODE’ 
assume cs:cseg,ds:cseg 

org 100h ; initial program counter for .COM file 

lobe 10: 

jmp label 1 ; jump around character set table 

even 


; definitions for 8 by 8 characters 80h through PFh 
csdefs db 087h.033h.03Fh.033h.087h.0E7h.0F3h.087h ; 080h 

db 0FFh.099h.0FFh.099h.099h.099h.0C0h.0FFh ; 081h 

db 0F1h,0FFh,0C3h.099h,081h,09Fh,0C3h.0FFh ; 082h 

db 081h.03Ch.0C3h.0F9h.0C1h.099h.0C0h.0FFh ; 083h 

db 099h,0FFh,0C3h,0F9h,0C1h,099h,0C0h.0FFh ; 084h 

db 08Fh.0FFh.0C3h.0F9h.0C1h.099h.0C0h.0FFh ; 085h 

db 0E7h.0E7h.0C3h.0F9h.0C1h.099h.0C0h.0FFh ; 086h 

db 0FFh,0FFh,0C3h,09Fh,09Fh,0C3h.0F9h,0E3h ; 087h 

db 081h.03Ch.0C3h.099h.081h.09Fh.0C3h.0FFh ; 088h 

db 099h.0FFh.0C3h.099h.081h.09Fh.0C3h,0FFh ; 089h 

db 08Fh,0FFh,0C3h,099h,081h,09Fh.0C3h,0FFh ; 08Ah 

db 099h.0FFh.0C7h.0E7h.0E7h.0E7h.0C3h.0FFh ; 08Bh 

db 083h.039h.0C7h.0E7h.0E7h.0E7h.0C3h.0FFh ; 08Ch 

db 08Fh.0FFh.0C7h.0E7h.0E7h.0E7h.0C3h.0FFh ; 08Dh 

db 09Ch,0E3h,0C9h,09Ch,080h,09Ch,09Ch,0FFh ; 08Eh 

db 0E7h.0E7h,0FFh,0C3h,099h,081h,099h,0FFh • 08Fh 

db 0F1h,0FFh,081h,0CFh,0C3h,0CFh,081h,0FFh ; 090h 

db 0FFh.0FFh.080h.0F3h.080h.033h.080h.0FFh ; 09ih 

db 0E0h,0C9h,099h,080h,099h,099h,098h,0FFh ; 092h 

db 0C3h.099h.0FFh.0C3h.099h.099h.0C3h.0FFh ; 093h 

db 0FFh.099h.0FFh.0C3h.099h.099h.0C3h.0FFh ; 094h 

db 0FFh.08Fh,0FFh.0C3h,099h,099h,0C3h,0FFh ; 095h 

db 0C3h.099h.0FFh.099h.099h.099h.0C0h.0FFh ; 096h 

db 0FFh,08Fh,0FFh,099h,099h,099h,0C0h,0FFh ; 097h 

db 0FFh.099h.0FFh.099h.099h.0C1h.0F9h.083h ; 098h 

db 03Ch,0E7h,0C3h,099h,099h,0C3h,0E7h,0FFh ; 099h 

db 099h.0FFh.099h.099h.099h.099h.0C3h.0FFh ; 09Ah 

db 0E7h.0E7h.081h.03Fh.03Fh.081h.0E7h.0E7h ; 09Bh 

db 0E3h.0C9h.0CDh.087h.0CFh.08Ch.081h,0FFh ; 09Ch 

db 099h,099h,0C3h,081h,0E7h,081h,0E7h,0E7h ; 09Dh 

db 007h.033h,033h,005h,039h,030h,039h,038h ; 09Eh 

db 0F1h,0E4h,0E7h,0C3h,0E7h,0E7h,027h,08Fh ; 09Fh 

db 0F1h.0FFh.0C3h.0F9h.0C1h.099h.0C0h.0FFh ; 0A0h 

db 0E3h.0FFh.0C7h.0E7h.0E7h.0E7h.0C3h.0FFh ; 0A1h 

db 0FFh,0F1h,0FFh,0C3h,099h.099h,0C3h,0FFh ; 0A2h 

db 0FFh.0F1h.0FFh.099h.099h.099h.0C0h.0FFh ; 0A3h 

db 0FFh,083h,0FFh,083h.099h.099h,099h,0FFh ; 0A4h 

db 081h,0FFh,099h,089h,081h,091h,099h,0FFh ; 0A5h 

db 0C3h.093h.093h.0C1h.0FFh.081h.0FFh.0FFh ; 0A6h 

db 0C7h,093h,093h,0C7h,0FFh,083h,0FFh,0FFh ; 0A7h 

db 0E7h,0FFh.0E7h,0CFh,09Fh,099h,0C3h,0FFh ; 0A8h 

db 0FFh.0FFh.0FFh.081h.09Fh.09Fh.0FFh.0FFh ; 0A9h 

db 0FFh.0FFh.0FFh.081h.0F9h.0F9h.0FFh.0FFh ; 0AAh 

db 03Ch . 039h , 033h, 021 h . 0CCh , 099h , 033h, 0F0h ; 0ABh 

db 03Ch,039h,033h,024h.0C8h,090h,030h,0FCh ; 0ACh 

db 0E7h.0E7h.0FFh.0E7h.0E7h.0E7h.0E7h.0FFh ; 0ADh 

db 0FFh,0CCh,099h,033h,099h,0CCh,0FFh,0FFh ; 0AEh 

db 0FFh.033h,099h,0CCh,099h,033h,0FFh.0FFh ; 0AFh 

db 0DDh.077h.0DDh.077h.0DDh.077h.0DDh.077h ; 0B0h 
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db 0AAh,055h,0AAh,055h,0AAh,055h,0AAh,055h ; 0B1h 
db 024h,088h,024h,011h,024h,088h,024h,011h ; 0B2h 
db 0E7h,0E7h,0E7h,0E7h,0E7h,0E7h,0E7h,0E7h ; 0B3h 
db 0E7h,0E7h,0E7h,0E7h,007h,0E7h,0E7h,0E7h ; 0B4h 
db 0E7h.0E7h,007h,0E7h,007h,0E7h,0E7h,0E7h ; 0B5h 
db ©CSh.OCgh.BCgh.BCgh.OBgh.OCgh.BCgh.BCSh ; 0B6h 
db BFFh.OFFh.OFFh.BFFh.OBIh.BCgh.OCgh.OCSh ; 0B7h 
db 0FFh,0FFh,007h,0E7h,007h,0E7h,0E7h.0E7h ; 0B8h 
db 0C9h,0C9h,009h,0F9h,009h.0C9h,0C9h,0C9h ; 0B9h 
db ©Cgh.BCSh.BCgh.BCgh.BCgh.BCSh.BCgh.BCgh ; 0BAh 
db ©FFh.BFFh.OBIh.BFSh.OBgh.BCgh.OCgh.BCSh ; 0BBh 
db 0C9h,0C9h,009h,0F9h,001h,0FFh,0FFh,0FFh ; 0BCh 
db 0C9h,0C9h,0C9h,0C9h,001h,0FFh,0FFh,0FFh ; 0BDh 
db 0E7h , 0E7h, 007h , 0E7h , 007h , 0FFh , 0FFh, 0FFh ; 0BEh 
db 0FFh,0FFh,0FFh,0FFh,007h,0E7h,0E7h,0E7h ; 0BFh 
db 0E7h,0E7h,0E7h,0E7h,0E0h,0FFh,0FFh,0FFh ; 0C0h 
db 0E7h,0E7h,0E7h,0E7h,000h,0FFh,0FFh,0FFh ; 0C1h 
db 0FFh,0FFh,0FFh,0FFh,000h,0E7h,0E7h,0E7h ; 0C2h 
db 0E7h,0E7h,0E7h,0E7h,0E0h,0E7h,0E7h,0E7h ; 0C3h 
db 0FFh,0FFh,0FFh,0FFh,000h,0FFh,0FFh,0FFh ; 0C4h 
db 0E7h,0E7h,0E7h,0E7h,000h,0E7h,0E7h,0E7h ; 0C5h 
db 0E7h,0E7h,0E0h,0E7h,0E0h,0E7h,0E7h,0E7h ; 0C6h 
db 009^009^009^009^008^009^009^009(1 ; 0C7h 
db 0C9h,0C9h,0C8h,0CFh,0C0h,0FFh,0FFh,0FFh ; 0C8h 
db 0FFh,0FFh,0C0h,0CFh,0C8h,0C9h,0C9h,0C9h ; 0C9h 
db 0C9h,0C9h,008h,0FFh,000h.0FFh,0FFh,0FFh ; 0CAh 
db 0FFh,0FFh,000h,0FFh,008h,0C9h,0C9h,0C9h ; 0CBh 
db 0C9h,0C9h,0C8h,0CFh, 008(1.009(1,009(1.009(1 : ©cch 

db 0FFh,0FFh,000h,0FFh,000h,0FFh,0FFh,0FFh ; 0CDh 

db 009(1.009(1,008(1,0FFh, 008(1,009(1,00911.009(1 : 0CEh 

db 0E7h,0E7h,000h,0FFh,000H,0FFh,0FFh,0FFh ; 0CFh 
db 0C9h,0C9h,0C9h,0C9h,000h,0FFh,0FFh,0FFh ; 0O0h 
db 0FFh,0FFh,000h,0FFh,000h,0E7h,0E7h,0E7h ; 0D1h 
db 0FFh,0FFh,0FFh,0FFh,000h,0C9h,0C9h,0C9h : 0D2h 
db 0C9h,0C9h,0C9h.0C9h,0C0h,0FFh.0FFh,0FFh ; 0D3h 
db 0E7h,0E7h,0E0h,0E7h,0E0h,0FFh,0FF(i,0FFh ; 0D4h 
db 0FFh,0FFh,0E0h,0E7h,0E0h,0E7h,0E7h,0E7h ; 0D5h 
db 0FFh,0FFh,0FFh,0FFh,0C0h,0C9h,0C9h,0C9h ; 0D6h 

db 009(1,009(1,009(1,009(1,000(1,009(1,009(1,009(1 ; ©D7h 

db 0E7h,0E7h,000h,0E7h,000h,0E7h, 0E7(i,0E7h ; 0D8h 
db 0E7h,0E7h,0E7h,0E7h,007h,0FFh,0FFh,0FFh : 0D9h 
db 0FFh,0FFh,0FFh,0FFh,0E0h,0E7h,0E7h,0E7h ; 0DAh 
db 000h , 000h , 000h , 000h , 000h , 000h , 000(i , 000h ; 0DBh 
db 0FFh,0FFh,0FFh,0FFh,000h,000h,000h,000h • 0DCh 
db 00Fh , 00Fh, 00Fh , 00Fh , 00Fh , 00Fh , 00Fh , 00Fh • 0DDh 
db 0F0h,0F0h,0F0h,0F0h,0F0h,0F0h,0F0h,0F0h • 0DEh 
db 000h,000h,000h,000h,0FFh,0FFh,0FFh,0FFh • 00Fh 
db 0FFh,0FFh,0C4h,091h,09Bh,091h,0C4h,0FFh ; 0E0h 
db 0FFh,0C3h,099h,083h,099h,083h,09Fh,09Fh ; 0E1h 
db 0FFh,081h,099h,09Fh,09Fh,09Fh,09F(i,0FFh • 0E2h 
db 0FFh,080h,0C9(i,0C9ti,0C9(i,0C9(i,0C9(»,0FFh ; 0E3h 
db 081h,099h,0CFh,0E7h,0CFh,099h,081h,0FFh ; 0E4h 
db 0FFh,0FFh,0C0h,093h,093h,093h,0C7h,0FFh ; 0E5h 
db 0FFh,0CCh,0CCh,0CCh,0CCh,0C1h,0CFh,09Fh ; 0E6h 
db 0FFh,0C4h,091h,0F3h,0F3h,0F3h,0F3h,0FFh ; 0E7h 
db 081h,0E7h,0C3h,099h,099(i,0C3h,0E7h,081h ; 0E8h 
db 0E3h,0C9h,09Ch,080h,09Ch,0C9h,0E3h,0FFh ; 0E9h 
db 0E3h,0C9h,09C(i,09Ch.0C9h,0C9h,088h,0FFh ; 0EAh 
db 0F1h,0E7h,0F3h.0C1h,099h,099h,0C3h,0FFh ; 0EBh 
db 0FFh,0FFh,081h,024h,024h,081h,0FFh.0FFh ; 0ECh 
db 0F9h,0F3h,081h,024h,024h,081h,09Fh,03Fh ; 0EDh 
db 0E3h,09Fh,03Fh,003h,03Fh,09Fh,0E3h,0FFh ; 0EEh 
db 0C3(i,099(i,099h.099h.099(i,099h,099h.0FFh ; 0EFh 
db 0FFh ,081h,0FFh ,081h ,0FFh ,081h ,0FFh ,0FFh • 0F0h 
db 0E7h,0E7h,081h,0E7h,0E7h,0FFh,081h,0FFh ; 0F1h 
db 0CFh,0E7h,0F3h,0E7h,0CFh,0FFh,081h,0FFh ; 0F2h 
db 0F3h,0E7h,0CFh,0E7h,0F3h,0FFh,081h,0FFh ; 0F3h 
db 0F1h,0E4h,0E4h,0E7h,0E7h,0E7h,0E7h,0E7h ; 0F4h 
db 0E7h,0E7h,0E7h,0E7h,0E7h,027h,027h,08Fh ; 0F5h 
db 0E7h,0E7h,0FFh,081h,0FFh,0E7h,0E7h,0FFh ; 0F6h 
db 0FFh,089h,023h,0FFh,089h,023h,0FFh,0FFh ; 0F7h 
db 0C7h,093h,093h,0C7h,0FFh,0FFh,0FFh,0FFh ; 0F8h 
db 0FFh,0FFh,0FFh,0E7h,0E7h,0FFh,0FFh,0FFh ; 0F9h 
db 0FFh.0FFh,0FFh,0FFh,0E7h,0FFh,0FFh,0FFh ; 0FAh 
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db 0F0h,0F3h,0F3h,0F3h,013h,093h,0C3h,0E3h ; 0FBh 
db 087h,093h,093h,093h,093h,0FFh,0FFh,0FFh ; 0FCh 
db 08Fh,0E7h,0CFh,09Fh,087h,0FFh,0FFh,0FFh ; 0FDh 
db 0FFh,0FFh,0C3h,0C3h,0C3h,0C3h,0FFh,0FFh ; 0FEh 
db 0FFh, 0FFh, 0FFh, 0FFh, 0FFh, 0FFh,0FFh,0FFh ; 0FFh 


label 1: 

; exit If new table same as current table 


mov 

a 1,IFh 


mov 

ah,35h 

; get interrupt IFh vector from DOS 

Int 

21 h 


mov 

di ,bx 

; ES:DI -> current table 

mov 

s 1 .offset csdefs 


push 

cs 


pop 

ds 

; DS:SI -> our table 

mov 

cx,1abe11-csdefs 

; size of table In bytes 

repe 

cmpsb 


Jne 

1abe12 

; jump if our table contains new data 

mov 

ax,4C00h 


int 

21h 

; exit to DOS 

put CGA Into 

All Points Addressi 

ible graphics mode so that DOS will use 

our character table 


abel2: mov 

al ,6 

; 640x200 2color APA graphics 

mov 

ah ,0 


Int 

10h 


point CGA graphics character generator to our character definitions 

mov 

dx,offset csdefs 


push 

cs 


pop 

ds 

; DS:DX points to our table 

mov 

al,IFh 

; Interrupt number 

mov 

ah,25h 

; DOS function number 

int 

21h 


; leave table 

resident in RAM 


mov 

dx,offset 1abe11 


mov 

cl ,4 


shr 

dx ,c 1 

; DX :■ size of resident table 

i nc 

dx 

; in paragraphs 

mov 

ax,3100h 


int 

21h 

; terminate and remain resident 


cseg ends 

end Iabel0 


CSLS3.ASM 

"RAM-Loadable Character Sets for the IBM PC," by 

Richard Wilton. Inside the IBM PCs, Extra Edition, page 197. 


title '256-character table for EGA* 
name csIs3 

page 55,132 


RAM-Loadable Character Sets for the IBM PC 
Listing 3 

Richard WiI ton 
July 1986 


Notes: 

This program loads a 256-character definition table for use In APA 
graphics modes. The program first selects an APA graphics mode. 
Then the BIOS pointers to the character set table are updated. 
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Use on IBM Enhanced Graphics Adopter ONLY. 


cseg 


Iabe10: 


segment para public ’CODE’ 
assume cs:cseg,ds:cseg 
org 100h 

jmp label 1 

even 


; initial program counter for .COM file 
; jump around character set table 


; definitions for 8 by 8 characters 00h through FFh 

csdefs db 0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh ; 000h 

db 081h.07Eh.05Ah.07Eh.042h.066h.07Eh.081h ; 001h 

db 081h,000h,024h.000h,03Ch.018h.000h,081h ; 002h 

db 093h,001h,001h.001h,083h,0C7h,0EFh,0FFh ; 003h 

db 0EFh.0C7h.083h.001h.083h.0C7h.0EFh.0FFh ; 004h 

db 0C7h.083h.0C7h.001h.001h.083h.0C7h.083h ; 005h 

db 0EFh.0EFh.0C7h.083h.001h.083h.0C7h.083h ; 006h 

db 0FFh.0FFh.0E7h.0C3h.0C3h.0E7h.0FFh.0FFh ; 007h 

db 000h,000h,018h.03Ch,03Ch,018h,000h.000h ; 008h 

db 0FFh.0C3h,099h,0BDh.0BDh.099h,0C3h.0FFh ; 009h 

db 000h.03Ch.066h.042h.042h.066h.03Ch.000h ; 00Ah 

db 0F0h,0F8h.0F0h,082h,033h,033h,033h,087h ; 008h 

db 0C3h,099h,099h,099h,0C3h,0E7h.081h.0E7h ; 00Ch 

db 0C0h.0CCh.0C0h.0CFh.0CFh.08Fh.00Fh.01Fh ; 00Dh 

db 080h.09Ch.080h.09Ch.09Ch.098h.019h.03Fh ; 00Eh 

db 066h.0A5h.0C3h.018h.018h.0C3h.0A5h.066h ; 00Fh 

db 07Fh.01Fh,007h,001h,007h,01Fh,07Fh,0FFh ; 010h 

db 0FDh.0F1h.0C1h.001h.0C1h.0F1h.0FDh.0FFh ; 011h 

db 0E7h.0C3h.081h.0E7h.0E7h.081h.0C3h.0E7h ; 012h 

db 099h,099h,099h,099h,099h,0FFh,099h,0FFh ; 013h 

db 080h.024h.024h.084h.0E4h.0E4h.0E4h.0FFh ; 014h 

db 0C1h.09Ch.0C7h.093h.093h.0C7h.033h.087h ; 015h 

db 0FFh.0FFh.0FFh.0FFh.081h.081h.081h.0FFh ; 016h 

db 0E7h.0C3h.081h.0E7h.081h.0C3h.0E7h.000h ; 017h 

db 0E7h.0C3h.081h.0E7h.0E7h.0E7h.0E7h.0FFh ; 018h 

db 0E7h,0E7h,0E7h,0E7h,081h,0C3h,0E7h,0FFh ; 019h 

db 0FFh.0E7h.0F3h.001h.0F3h.0E7h.0FFh.0FFh ; 01Ah 

db 0FFh.0CFh.09Fh.001h.09Fh.0CFh.0FFh.0FFh ; 01Bh 

db 0FFh.0FFh.03Fh.03Fh.03Fh.001h.0FFh.0FFh ; 01Ch 

db 0FFh.0DBh.099h.000h.099h.0DBh.0FFh.0FFh ; 01Dh 

db 0FFh.0E7h.0C3h.081h.000h.000h.0FFh.0FFh ; 01Eh 

db 0FFh.000h.000h.081h.0C3h.0E7h.0FFh.0FFh ; 01Fh 

db 0FFh.0FFh,0FFh.0FFh.0FFh.0FFh.0FFh.0FFh ; 020h 

db 0CFh.087h.087h,0CFh,0CFh,0FFh,0CFh,0FFh ; 021h 

db 093h.093h.093h.0FFh.0FFh.0FFh.0FFh.0FFh ; 022h 

db 093h.093h.001h.093h.001h.093h.093h.0FFh ; 023h 

db 0CFh.083h.03Fh.087h.0F3h.007h.0CFh.0FFh ; 024h 

db 0FFh,039h,033h.0E7h,0CFh.099h,039h.0FFh ; 025h 

db 0C7h.093h,0C7h.089h.023h,033h,089h,0FFh ; 026h 

db 09Fh,09Fh.03Fh,0FFh,0FFh,0FFh,0FFh,0FFh ; 027h 

db 0E7h.0CFh.09Fh.09Fh,09Fh,0CFh.0E7h,0FFh ; 028h 

db 09Fh,0CFh.0E7h.0E7h,0E7h.0CFh.09Fh,0FFh ; 029h 

db 0FFh,099h,0C3h.000h,0C3h,099h,0FFh,0FFh ; 02Ah 

db 0FFh.0CFh.0CFh.003h.0CFh.0CFh.0FFh.0FFh ; 02Bh 

db 0FFh,0FFh,0FFh,0FFh,0FFh,0CFh,0CFh,09Fh ; 02Ch 

db 0FFh.0FFh.0FFh.003h.0FFh.0FFh.0FFh.0FFh ; 02Dh 

db 0FFh,0FFh.0FFh.0FFh.0FFh,0CFh.0CFh.0FFh ; 02Eh 

db 0F9h.0F3h,0E7h.0CFh.09Fh.03Fh.07Fh,0FFh ; 02Fh 

db 083h.039h.031h.021h.009h.019h.083h.0FFh ; 030h 

db 0CFh.08Fh.0CFh.0CFh.0CFh.0CFh.003h.0FFh ; 031h 

db 087h.033h.0F3h.0C7h.09Fh.033h.003h.0FFh ; 032h 

db 087h.033h.0F3h.0C7h.0F3h.033h.087h.0FFh ; 033h 

db 0E3h.0C3h.093h.033h.001h.0F3h.0E1h.0FFh ; 034h 

db 003h.03Fh.007h.0F3h.0F3h.033h.087h.0FFh ; 035h 

db 0C7h,09Fh,03Fh.007h,033h.033h,087h,0FFh ; 036h 

db 003h.033h.0F3h.0E7h.0CFh.0CFh.0CFh.0FFh ; 037h 

db 087h.033h.033h.087h.033h.033h.087h.0FFh ; 038h 

db 087h.033h.033h.083h.0F3h.0E7h.08Fh.0FFh ; 039h 

db 0FFh,0CFh.0CFh.0FFh.0FFh,0CFh.0CFh.0FFh ; 03Ah 

db 0FFh,0CFh.0CFh.0FFh,0FFh,0CFh.0CFh.09Fh ; 03Bh 

db 0E7h.0CFh.09Fh.03Fh.09Fh.0CFh.0E7h.0FFh ; 03Ch 

db 0FFh.0FFh.003h.0FFh.0FFh.003h.0FFh.0FFh ; 03Dh 


[continued) 
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db 09Fh,0CFh.0E7h.0F3h,0E7h,0CFh.09Fh.0FFh ; 03Eh 

db 087h.033h,0F3h,0E7h,0CFh,0FFh,0CFh.0FFh ; 03Fh 

db 083h.039h.021h.021h,021h,03Fh,087h,0FFh ; 040h 

db 0CFh,087h.033h.033h,003h,033h,033h,0FFh ; 041h 

db 003h,099h,099h,083h,099h,099h,003h.0FFh ; 042h 

db 0C3h.099h,03Fh.03Fh.03Fh,099h,0C3h,0FFh ; 043h 

db 007h,093h,099h.099h.099h,093h,007h,0FFh ; 044h 

db 001h ,09Dh ,097h ,087h ,097h , 09Dh ,001h ,0FFh ; 045h 

db 001h,09Dh,097h,087h,097h,09Fh,00Fh,0FFh ; 046h 

db 0C3h , 099h , 03Fh , 03Fh , 031 h , 099h , 0C1 h, 0FFh ; 047h 

db 033h, 033h, 033h, 003h, 033h, 033h, 033h, 0FFh ; 048h 

db 087h.0CFh,0CFh,0CFh.0CFh,0CFh,087h.0FFh ; 049h 

db 0E1h,0F3h,0F3h,0F3h,033h,033h,087h,0FFh ; 04Ah 

db 019h,099h,093h,087h,093h,099h,019h,0FFh ; 04Bh 

db OOFh.OgFh^gFh.OgFh.OgDh.Oggh.BOlh.OFFh ; 04Ch 

db 039h ,011h,001h ,001h ,029h ,039h ,039h ,0FFh ; 04Dh 

db 039h,019h.009h.021h,031h.039h,039h,0FFh ; 04Eh 

db 0C7h,093h,039h.039h,039h,093h.0C7h.0FFh ; 04Fh 

db 003h,099h,099h,083h,09Fh,09Fh,00Fh,0FFh ; 050h 

db 087h,033h.033h.033h,023h,087h.0E3h,0FFh ; 051h 

db 003h,099h.099h.083h,093h,099h,019h,0FFh ; 052h 

db 087h,033h,01Fh,08Fh,0E3h.033h.087h,0FFh ; 053h 

db 003h,04Bh,0CFh.0CFh,0CFh.0CFh,087h,0FFh ; 054h 

db 033h , 033h , 033h , 033h , 033h , 033h , 003h , 0FFh ; 055h 

db 033h , 033h , 033h , 033h , 033h , 087h , 0CFh , 0FFh ; 056h 

db 039h,039h,039h,029h,001h,011h,039h,0FFh ; 057h 

db 039h,039h,093h,0C7h.0C7h,093h,039h,0FFh ; 058h 

db 033h , 033h , 033h , 087h, 0CFh , 0CFh, 087h , 0FFh ; 059h 

db 001h,039h,073h,0E7h,0CDh,099h,001h,0FFh ; 05Ah 

db 087h.09Fh.09Fh,09Fh.09Fh,09Fh,087h.0FFh ; 05Bh 

db 03Fh,09Fh,0CFh,0E7h,0F3h,0F9h,0FDh,0FFh ; 05Ch 

db 087h,0E7h,0E7h,0E7h,0E7h,0E7h,087h,0FFh ; 05Dh 

db 0EFh , 0C7h , 093h , 039h , 0FFh , 0FFh , 0FFh, 0FFh ; 05Eh 

db 0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,000h ; 05Fh 

db 0CFh,0CFh,0E7h,0FFh,0FFh.0FFh.0FFh,0FFh ; 060h 

db 0FFh , 0FFh , 087h, 0F3h , 083h , 033h, 089h , 0FFh ; 061h 

db 01Fh,09Fh,09Fh,083h,099h,099h,023h,0FFh ; 062h 

db 0FFh,0FFh,087h,033h,03FH,033h,087h,0FFh ; 063h 

db 0E3h.0F3h.0F3h,083h,033h,033h,089h,0FFh ; 064h 

db 0FFh,0FFh,087h,033h,003h,03Fh,087h,0FFh ; 065h 

db 0C7h,093h,09Fh,00Fh,09Fh,09Fh,00Fh,0FFh ; 066h 

db 0FFh,0FFh,089h,033h,033h,083h,0F3h,007h ; 067h 

db 01Fh,09Fh,093h,089h.099h,099h,019h,0FFh ; 068h 

db 0CFh,0FFh,08Fh,0CFh,0CFh,0CFh,087h,0FFh ; 069h 

db 0F3h,0FFh,0F3h,0F3h,0F3h,033h,033h,087h ; 06Ah 

db 01Fh,09Fh,099h,093h,087h,093h,019h,0FFh ; 06Bh 

db 08Fh,0CFh.0CFh,0CFh,0CFh,0CFh,087h.0FFh ; 06Ch 

db 0FFh,0FFh,033h,001h,001h,029h,039h,0FFh ; 06Dh 

db 0FFh,0FFh,007h.033h,033h.033h,033h,0FFh ; 06Eh 

db 0FFh,0FFh,087h,033h,033h,033h,087h,0FFh ; 06Fh 

db 0FFh.0FFh.023h,099h,099h.083h,09Fh.00Fh ; 070h 

db 0FFh,0FFh,089h,033h,033h,083h,0F3h,0E1h ; 071h 

db 0FFh,0FFh,023h,089h,099h.09Fh,00Fh.0FFh ; 072h 

db 0FFh,0FFh,083h.03Fh,087h,0F3h,007h,0FFh ; 073h 

db 0EFh, 0CFh, 083h, 0CFh, 0CFh, 0CBh, 0E7h, 0FFh ; 074h 

db 0FFh , 0FFh , 033h , 033h , 033h , 033h, 089h , 0FFh ; 075h 

db 0FFh.0FFh.033h,033h,033h,087h,0CFh,0FFh ; 076h 

db 0FFh,0FFh,039h,029h,001h,001h,093h,0FFh ; 077h 

db 0FFh,0FFh,039h,093h,0C7h,093h,039h,0FFh ; 078h 

db 0FFh,0FFh,033h,033h.033h.083h.0F3h,007h ; 079h 

db 0FFh,0FFh,003h,067h,0CFh,098h,003h,0FFh ; 07Ah 

db 0E3h , 0CFh, 0CFh , 01 Fh , 0CFh, 0CFh , 0E3h , 0FFh ; 07Bh 

db 0E7h,0E7h,0E7h,0FFh,0E7h,0E7h.0E7h,0FFh ; 07Ch 

db 01 Fh , 0CFh, 0CFh , 0E3h , 0CFh , 0CFh, 01Fh , 0FFh ; 07Oh 

db 089h,023h,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh ; 07Eh 

db 0FFh,0EFh,0C7h,093h,039h,039h,001h,0FFh ; 07Fh 

hi_haIf db 087h,033h.03Fh,033h,087h,0E7h,0F3h,087h ; 080h 

db 0FFh,099h,0FFh,099h,099h,099h,0C0h,0FFh ; 081h 

db 0F1 h, 0FFh, 0C3h , 099h , 081 h , 09Fh , 0C3h , 0FFh ; 082h 

db 081h,03Ch,0C3h,0F9h,0C1h,099h,0C0h,0FFh ; 083h 

db 099h,0FFh,0C3h,0F9h,0C1h,099h,0C0h,0FFh ; 084h 

db 08Fh,0FFh,0C3h,0F9h,0C1h,099h,0C0h,0FFh ; 085h 

db 0E7h,0E7h,0C3h,0F9h,0C1h,099h,0C0h,0FFh : 086h 

db 0FFh,0FFh,0C3h.09Fh,09Fh,0C3h,0F9h.0E3h ; 087h 

db 081h,03Ch,0C3h,099h,081h,09Fh,0C3h,0FFh ; 088h 

db 099h,0FFh,0C3h,099h,081h,09Fh,0C3h,0FFh ; 089h 
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db 08Fh,0FFh,0C3h,099h,081h,09Fh,0C3h,0FFh ; 08Ah 
db 099h,0FFh,0C7h,0E7h,0E7h,0E7h,0C3h,0FFh ; 08Bh 
db 083h,039h,0C7h,0E7h,0E7h,0E7h,0C3h,0FFh ; 08Ch 
db 08Fh,0FFh,0C7h,0E7h,0E7h,0E7h,0C3h,0FFh ; 08Dh 
db 09Ch,0E3h,0C9h,09Ch,080h,09Ch,09Ch,0FFh ; 08Eh 
db 0E7h,0E7h,0FFh,0C3h,099h,081h,099h,0FFh ; 08Fh 
db 0F1h,0FFh,081h,0CFh,0C3h,0CFh, 081h,0FFh ; 090h 
db 0FFh,0FFh,080h,0F3h,080h,033h,080h,0FFh ; 091h 
db 0E0h,0C9h,099h,080h,099h,099h,098h,0FFh ; 092h 
db 0C3h,099h,0FFh,0C3h,099h,099h,0C3h,0FFh ; 093h 
db 0FFh,099h,0FFh,0C3h,099h,099h,0C3h,0FFh ; 094h 
db 0FFh,08Fh,0FFh,0C3h,099h,099h,0C3h,0FFh ; 095h 
db 0C3h,099h,0FFh,099h,099h,099h,0C0h,0FFh ; 096h 
db 0FFh,08Fh,0FFh,099h,099h,099h,0C0h,0FFh ; 097h 
db 0FFh,099h,0FFh,099h,099h,0C1h,0F9h,083h ; 098h 
db 03Ch,0E7h,0C3h,099h,099h,0C3h,0E7h,0FFh ; 099h 
db 099h,0FFh,099h,099h,099h,099h,0C3h,0FFh ; 09Ah 
db 0E7h,0E7h,081h,03Fh,03Fh,081h, 0E7h,0E7h ; 09Bh 
db 0E3h,0C9h,0CDh,087h,0CFh,08Ch,081h,0FFh ; 09Ch 
db 099h,099h,0C3h,081h,0E7h,081h,0E7h,0E7h ; 09Dh 
db 007h,033h,033h,005h,039h,030h,039h,038h ; 09Eh 
db 0F1h,0E4h,0E7h,0C3h,0E7h,0E7h,027h,08Fh ; 09Fh 
db 0F1h,0FFh, 0C3h,0F9h,0C1h,099h, 0C0h,0FFh ; 0A0h 
db 0E3h,0FFh,0C7h,0E7h,0E7h,0E7h,0C3h,0FFh ; 0A1h 
db 0FFh,0F1h,0FFh,0C3h,099h,099h, 0C3h,0FFh ; 0A2h 
db 0FFh,0F1h,0FFh,099h,099h,099h,0C0h,0FFh ; 0A3h 
db 0FFh,083h,0FFh.083h,099h,099h,099h,0FFh ; 0A4h 
db 081h,0FFh,099h,089h,081h,091h,099h,0FFh ; 0A5h 
db 0C3h,093h,093h,0C1h,0FFh,081h,0FFh,0FFh ; 0A6h 
db 0C7h,093h,093h,0C7h,0FFh,083h,0FFh,0FFh ; 0A7h 
db 0E7h,0FFh,0E7h,0CFh,09Fh,099h,0C3h,0FFh ; 0A8h 
db 0FFh,0FFh,0FFh,081h,09Fh,09Fh,0FFh,0FFh ; 0A9h 
db 0FFh,0FFh,0FFh,081h,0F9h,0F9h,0FFh,0FFh ; 0AAh 
db 03Ch,039h,033h,021h,0CCh,099h,033h,0F0h ; 0ABh 
db 03Ch,039h,033h,024h,0C8h,090h,030h,0FCh ; 0ACh 
db 0E7h,0E7h,0FFh,0E7h,0E7h,0E7h,0E7h,0FFh ; 0ADh 
db 0FFh,0CCh,099h,033h,099h,0CCh,0FFh,0FFh ; 0AEh 
db 0FFh,033h,099h,0CCh,099h,033h,0FFh,0FFh ; 0AFh 
db 0DDh,077h,0DDh,077h,0DDh,077h,0DDh,077h ; 0B0h 
db 0AAh,055h,0AAh,055h,0AAh,055h,0AAh,055h ; 0B1h 
db 024h,088h,024h,011h,024h,088h,024h,011h ; 0B2h 
db 0E7h,0E7h,0E7h,0E7h,0E7h,0E7h,0E7h,0E7h ; 0B3h 
db 0E7h,0E7h,0E7h,0E7h,007h,0E7h,0E7h,0E7h ; 0B4h 
db 0E7h,0E7h,007h,0E7h,007h,0E7h,0E7h,0E7h ; 0B5h 
db 0C9h,0C9h,0C9h,0C9h,009h,0C9h,0C9h,0C9h ; 0B6h 
db 0FFh,0FFh t 0FFh,0FFh,001h,0C9h,0C9h,0C9h ; 0B7h 
db 0FFh,0FFh,007h,0E7h,007h,0E7h,0E7h,0E7h ; 0B8h 
db 0C9h,0C9h,009h,0F9h,009h,0C9h,0C9h,0C9h ; 0B9h 
db 0C9h,0C9h,0C9h,0C9h,0C9h,0C9h,0C9h,0C9h ; 0BAh 
db 0FFh,0FFh,001h,0F9h,009h,0C9h,0C9h,0C9h ; 0BBh 
db 0C9h,0C9h,009h,0F9h,001h,0FFh,0FFh,0FFh ; 0BCh 
db 0C9h,0C9h,0C9h,0C9h,001h,0FFh,0FFh,0FFh ; 0BDh 
db 0E7h,0E7h,007h,0E7h,007h,0FFh,0FFh,0FFh ; 0BEh 
db 0FFh,0FFh t 0FFh,0FFh,007h,0E7h,0E7h,0E7h ; 0BFh 
db 0E7h,0E7h,0E7h,0E7h,0E0h,0FFh,0FFh,0FFh ; 0C0h 
db 0E7h,0E7h,0E7h,0E7h,A00h,0FFh,0FFh,0FFh ; 0C1h 
db 0FFh,0FFh,0FFh,0FFh,000h,0E7h,0E7h,0E7h ; 0C2h 
db 0E7h,0E7h,0E7h,0E7h,0E0h,0E7h,0E7h,0E7h ; 0C3h 
db 0FFh,0FFh,0FFh,0FFh,000h,0FFh,0FFh,0FFh ; 0C4h 
db 0E7h,0E7h,0E7h,0E7h,000h,0E7h,0E7h,0E7h ; 0C5h 
db 0E7h,0E7h,0E0h,0E7h,0E0h,0E7h,0E7h,0E7h ; 0C6h 
db 0C9h,0C9h,0C9h,0C9h,0C8h,0C9h,0C9h,0C9h ; 0C7h 
db 0C9h,0C9h,0C8h,0CFh,0C0h,0FFh,0FFh,0FFh ; 0C8h 
db 0FFh,0FFh,0C0h,0CFh,0C8h,0C9h,0C9h,0C9h ; 0C9h 
db 0C9h,0C9h,008h,0FFh,000h,0FFh,0FFh,0FFh ; 0CAh 
db 0FFh,0FFh,000h,0FFh,008h,0C9h,0C9h,0C9h ; 0CBh 
db 0C9h,0C9h,0C8h,0CFh,0C8h,0C9h,0C9h,0C9h ; 0CCh 
db 0FFh,0FFh,000h,0FFh,000h,0FFh,0FFh,0FFh ; 0CDh 
db 0C9h,0C9h,008h,0FFh,008h,0C9h,0C9h,0C9h ; 0CEh 
db 0E7h,0E7h,000h,0FFh,000h,0FFh,0FFh,0FFh ; 0CFh 
db 0C9h,0C9h,0C9h,0C9h,000h,0FFh,0FFh.0FFh ; 0D0h 
db 0FFh,0FFh,000h,0FFh,000h,0E7h,0E7h,0E7h ; 0D1h 
db 0FFh,0FFh,0FFh,0FFh,000h,0C9h,0C9h,0C9h ; 0D2h 
db 0C9h,0C9h,0C9h,0C9h,0C0h,0FFh,0FFh,0FFh ; 0D3h 
db 0E7h,0E7h,0E0h,0E7h,0E0h,0FFh,0FFh,0FFh ; 0D4h 
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db 0FFh,0FFh,0E0h,0E7h,0E0h,0E7h,0E7h,0E7h ; 0D5h 
db 0FFh,0FFh,0FFh,0FFh,0C0h,0C9h,0C9h,0C9h ; 0D6h 
db 0C9h,0C9h,0C9h,0C9h,000h,0C9h,0C9h,0C9h ; 0D7h 
db 0E7h,0E7h,000h,0E7h,000h,0E7h,0E7h,0E7h ; 0D8h 
db 0E7h,0E7h,0E7h,0E7h,007h,0FFh,0FFh,0FFh ; 0D9h 
db 0FFh,0FFh,0FFh,0FFh,0E0h,0E7h,0E7h,0E7h ; 0DAh 
db 000h,000h,000h,000h,000h,000h,000h,000h ; 0DBh 
db 0FFh,0FFh,0FFh,0FFh,000h,000h,000h,000h ; 0DCh 
db 00Fh,00Fh,00Fh,00Fh,00Fh,00Fh,00Fh,00Fh ; 0DDh 
db 0F0h,0F0h,0F0h,0F0h,0F0h,0F0h,0F0h,0F0h ; 0DEh 
db 000h,000h,000h,000h,0FFh,0FFh,0FFh,0FFh ; 0DFh 
db 0FFh, 0FFh, 0C4h,091h,09Bh, 091h,0C4h, 0FFh ; 0E0h 
db 0FFh,0C3h,099h,083h,099h,083h,09Fh,09Fh ; 0E1h 
db 0FFh,081h, 099h,09Fh,09Fh,09Fh, 09Fh,0FFh ; 0E2h 
db 0FFh,080h,0C9h,0C9h,0C9h,0C9h,0C9h,0FFh ; 0E3h 
db 081h,099h,0CFh,0E7h, 0CFh,099h,081h,0FFh ; 0E4h 
db 0FFh,0FFh,0C0h,093h,093h,093h,0C7h,0FFh ; 0E5h 
db 0FFh,0CCh,0CCh,0CCh,0CCh,0C1h,0CFh,09Fh ; 0E6h 
db 0FFh,0C4h,091h,0F3h,0F3h,0F3h,0F3h,0FFh ; 0E7h 
db 081h, 0E7h, 0C3h,099h,099h,0C3h, 0E7h,081h ; 0E8h 
db 0E3h,0C9h,09Ch,080h,09Ch,0C9h,0E3h,0FFh ; 0E9h 
db 0E3h,0C9h,09Ch,09Ch,0C9h,0C9h,088h,0FFh ; 0EAh 
db 0F1h,0E7h,0F3h,0C1h,099h,099h,0C3h,0FFh ; 0EBh 
db 0FFh,0FFh,081h,024h,024h,081h,0FFh,0FFh ; 0ECh 
db 0F9h,0F3h,081h,024h,024h,081h,09Fh,03Fh ; 0EDh 
db 0E3h,09Fh,03Fh,003h,03Fh,09Fh,0E3h,0FFh ; 0EEh 
db 0C3h,099h,099h,099h,099h,099h,099h,0FFh ; 0EFh 
db 0FFh,081h,0FFh,081h,0FFh,081h,0FFh,0FFh ; 0F0h 
db 0E7h,0E7h,081h,0E7h,0E7h,0FFh,081h,0FFh ; 0F1h 
db 0CFh,0E7h,0F3h,0E7h,0CFh,0FFh,081h,0FFh ; 0F2h 
db 0F3h,0E7h,0CFh,0E7h,0F3h,0FFh,081h,0FFh ; 0F3h 
db 0F1h,0E4h,0E4h,0E7h,0E7h,0E7h,0E7h,0E7h ; 0F4h 
db 0E7h,0E7h,0E7h,0E7h,0E7h,027h,027h,08Fh ; 0F5h 
db 0E7h,0E7h,0FFh,081h,0FFh,0E7h,0E7h,0FFh ; 0F6h 
db 0FFh,089h,023h,0FFh,089h,023h,0FFh,0FFh ; 0F7h 
db 0C7h,093h,093h,0C7h,0FFh,0FFh,0FFh,0FFh ; 0F8h 
db 0FFh,0FFh,0FFh,0E7h,0E7h,0FFh l 0FFh,0FFh ; 0F9h 
db 0FFh,0FFh,0FFh t 0FFh,0E7h,0FFh,0FFh,0FFh ; 0FAh 
db 0F0h,0F3h,0F3h,0F3h,013h,093h,0C3h,0E3h ; 0FBh 
db 087h,093h,093h,093h,093h,0FFh,0FFh,0FFh ; 0FCh 
db 08Fh,0E7h l 0CFh > 09Fh,087h,0FFh,0FFh,0FFh ; 0FDh 
db 0FFh,0FFh,0C3h,0C3h,0C3h,0C3h,0FFh,0FFh ; 0FEh 
db 0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh ; 0FFh 


Iabe 11: 

; exit if new table same as current table 


mov 

bh, 1 

; request for char table address 

mov 

a 1,30h 

; BIOS Info request 

mov 

ah, 11h 

; BIOS char generator function 

int 

10h 

; BIOS sets ES:BP to point to table 

mov 

di ,bp 

; ES:DI -> current table 

mov 

si.offset csdefs 


push 

cs 


pop 

ds 

; DS:SI -> our table 

mov 

cx,1abe11-csdefs 

; size of table in bytes 

repe 

cmpsb 

jne 

1 abe12 

; jump if our table contains new data 

mov 

ax,4C00h 


int 

21h 

; exit to DOS 


; put EGA into All Points Addressible graphics mode so that DOS will use 
; our character table 

Iabe12: mov al,6 ; 640x200 2color APA graphics 

mov ah,0 

int 10h 

; point EGA graphics character generator to our character definitions 
mov bp,offset csdefs 

push cs 

pop es ; ES:BP points to our table 
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cseg 


mov 

cx,8 


CX :« bytes/character in tabh 

mov 

bl .0 


BL := 0 (BIOS wi11 use DL for 




number of rows on screen) 

mov 

d1,19h 


DL := 25 (number of character 




on screen) 

mov 

a 1,21h 


"user graphics character load 

mov 

ah.llh 


BIOS "character generator rou 

int 

10h 


cal 1 EGA BIOS 

>mpati 

bility, point interrupt 

IFh 

vector to characters 80h - FFh 

mov 

bp,offset h ?_h a 1f 



push 

cs 



pop 

es 

i 

; ES:BP -> 2nd half of table 

mov 

a 1,20h 

i 

"int IFh load" 

mov 

ah.llh 



int 

10h 



tab 1 e 

resident in RAM 



mov 

dx,offset 1abe11 



mov 

cl .4 



shr 

dx,cl 

i 

; DX :* size of resident table 

i nc 

dx 


; in paragraphs 

mov 

ax,3100h 



int 

21h 


; terminate and remain resident 

ends 




end 

1 abe 10 




CSLS4.ASM 

"RAM-Loadable Character Sets for the IBM PC," by 
Richard Wilton. Inside the IBM PCs, Extra Edition, page 197. 


title '256-character table for EGA* 
name csls4 

page 55,132 


RAM-Loadable Character Sets for the IBM PC 
Listing 4 

Richard WiI ton 
July 1986 


Notes: 

This program loads a 256-character definition table for use in 
alphanumeric video display modes. The program assumes 
that the proper video mode has already been established. 

For IBM Enhanced Graphics Adapter ONLY. Color display recommended. 


cseg 


segment para public 'CODE' 
assume cs:cseg,ds:cseg 
org 100h 


Iabe10: 

jmp Iabe11 

even 


; initial program counter for .COM file 
; jump around character set table 


; definitions for 8 by 8 characters 00h through FFh 

csdefs db 0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh ; 000h 

db 081h,07Eh,05Ah,07Eh,042h,066h,07Eh,081h ; 001h 

db 081h,000h,024h,000h,03Ch,018h,000h,081h ; 002h 

db 093h,001h,001h,001h,083h,0C7h,0EFh,0FFh ; 003h 

db 0EFh,0C7h,083h,001h,083h,0C7h,0EFh,0FFh ; 004h 

db 0C7h,083h,0C7h,001h,001h,083h,0C7h,083h ; 005h 
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db 0EFh,0EFh,0C7h,083h,001h,083h,0C7h,083h ; 006h 
db 0FFh,0FFh,0E7h,0C3h,0C3h,0E7h,0FFh,0FFh j 007h 
db 000h , 000h , 018h , 03Ch, 03Ch , 018h , 000h , 000h ; 008h 
db 0FFh,0C3h,099h,0BDh,0BDh,099h.0C3h,0FFh ; 009h 
db 000h,03Ch,066h,042h,042h,066h,03Ch.000h ; 00Ah 
db 0F0h,0F8h,0F0h,082h,033h,033h,033h,087h ; 00Bh 
db 0C3h,099h,099h,099h,0C3h,0E7h,081h.0E7h ; 00Ch 
db 0C0h,0CCh,0C0h.0CFh,0CFh,08Fh,00Fh,01Fh ; 00Dh 
db 080h,09Ch,080h,09Ch,09Ch,098h,019h,03Fh ; 00Eh 
db 066h,0A5h,0C3h,018h,018h,0C3h,0A5h,066h ; 00Fh 
db 07Fh ,01Fh ,007h ,001h,007h ,01Fh ,07Fh,0FFh ; 010h 
db 0FDh , 0F1 h , 0C1 h, 001 h. 0C1 h , 0F1 h, 0FDh , 0FFh ; 011h 
db 0E7h,0C3h,081h,0E7h,0E7h,081h,0C3h,0E7h ; 012h 
db 099h,099h,099h,099h,099h,0FFh,099h,0FFh ; 013h 
db 080h.024h,024h.084h,0E4h,0E4h,0E4h,0FFh ; 014h 
db 0C1h,09Ch,0C7h,093h,093h,0C7h,033h,087h ; 015h 
db 0FFh,0FFh,0FFh,0FFh,081h,081h,081h,0FFh ; 016h 
db 0E7h,0C3h,081h,0E7h,081h,0C3h,0E7h,000h ; 017h 
db 0E7h,0C3h,081h,0E7h,0E7h,0E7h,0E7h,0FFh ; 018h 
db 0E7h,0E7h,0E7h,0E7h,081h,0C3h,0E7h,0FFh ; 019h 
db 0FFh,0E7h,0F3h,001h,0F3h,0E7h,0FFh,0FFh ; 01Ah 
db 0FFh,0CFh,09Fh,001h,09Fh,0CFh.0FFh,0FFh ; 01Bh 
db 0FFh , 0FFh , 03Fh , 03Fh, 03Fh , 001 h, 0FFh , 0FFh ; 01Ch 
db 0FFh,0DBh.099h,000h,099h,0DBh,0FFh,0FFh ; 01Dh 
db 0FFh,0E7h,0C3h.081h,000h,000h,0FFh,0FFh ; 01Eh 
db 0FFh,000h,000h,081h,0C3h,0E7h,0FFh,0FFh ; 01Fh 
db 0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh ; 020h 
db 0CFh,087h,087h,0CFh,0CFh,0FFh,0CFh,0FFh ; 021h 
db 093h.093h,093h,0FFh,0FFh.0FFh,0FFh,0FFh ; 022h 
db 093h , 093h , 001 h , 093h , 001 h, 093h , 093h , 0FFh ; 023h 
db 0CFh,083h.03Fh,087h,0F3h,007h,0CFh,0FFh ; 024h 
db 0FFh,039h,033h,0E7h,0CFh,099h,039h,0FFh ; 025h 
db 0C7h,093h,0C7h,089h,023h,033h,089h,0FFh ; 026h 
db 09Fh.09Fh.03Fh.0FFh.0FFh.0FFh.0FFh,0FFh ; 027h 
db 0E7h,0CFh,09Fh,09Fh.09Fh,0CFh.0E7h,0FFh ; 028h 
db 09Fh,0CFh,0E7h,0E7h,0E7h,0CFh,09Fh,0FFh ; 029h 
db 0FFh,099h,0C3h,000h,0C3h,099h,0FFh,0FFh ; 02Ah 
db 0FFh,0CFh,0CFh,003h,0CFh,0CFh,0FFh,0FFh ; 02Bh 
db 0FFh,0FFh,0FFh,0FFh,0FFh,0CFh,0CFh,09Fh ; 02Ch 
db 0FFh , 0FFh, 0FFh , 003h . 0FFh , 0FFh , 0FFh, 0FFh ; 02Dh 
db 0FFh,0FFh,0FFh,0FFh,0FFh,0CFh,0CFh,0FFh ; 02Eh 
db 0F9h,0F3h,0E7h,0CFh,09Fh,03Fh,07Fh,0FFh ; 02Fh 
db 083h,039h,031h,021h,009h,019h,083h,0FFh ; 030h 
db 0CFh , 08Fh , 0CFh , 0CFh, 0CFh, 0CFh , 003h , 0FFh ; 031h 
db 087h,033h,0F3h,0C7h,09Fh,033h,003h,0FFh ; 032h 
db 087h,033h,0F3h,0C7h,0F3h,033h,087h,0FFh ; 033h 
db 0E3h.0C3h.093h.033h,001h,0F3h,0E1h,0FFh ; 034h 
db 003h.03Fh.007h.0F3h.0F3h.033h.087h.0FFh ; 035h 
db 0C7h.09Fh.03Fh.007h.033h.033h.087h.0FFh ; 036h 
db 003h.033h.0F3h.0E7h.0CFh.0CFh.0CFh.0FFh ; 037h 
db 087h.033h.033h.087h.033h.033h.087h.0FFh ; 038h 
db 087h.033h.033h.083h.0F3h.0E7h.08Fh.0FFh ; 039h 
db 0FFh.0CFh.0CFh.0FFh.0FFh,0CFh,0CFh.0FFh ; 03Ah 
db 0FFh.0CFh.0CFh.0FFh.0FFh.0CFh.0CFh.09Fh ; 03Bh 
db 0E7h.0CFh.09Fh.03Fh.09Fh.0CFh.0E7h.0FFh ; 03Ch 
db 0FFh.0FFh.003h.0FFh.0FFh.003h.0FFh.0FFh ; 03Dh 
db 09Fh.0CFh,0E7h,0F3h,0E7h,0CFh,09Fh,0FFh ; 03Eh 
db 087h.033h.0F3h.0E7h.0CFh.0FFh.0CFh.0FFh ; 03Fh 
db 083h.039h.021h.021h.021h.03Fh.087h.0FFh ; 040h 
db 0CFh,087h.033h.033h,003h,033h,033h,0FFh ; 041h 
db 003h.099h.099h.083h.099h.099h.003h.0FFh ; 042h 
db 0C3h,099h.03Fh,03Fh.03Fh.099h,0C3h,0FFh ; 043h 
db 007h.093h.099h.099h.099h.093h.007h.0FFh ; 044h 
db 001h.09Dh.097h.087h.097h.09Dh.001h.0FFh ; 045h 
db 001h,09Dh,097h,087h,097h,09Fh,00Fh,0FFh ; 046h 
db 0C3h.099h.03Fh.03Fh.031h.099h.0C1h.0FFh ; 047h 
db 033h.033h.033h.003h.033h.033h.033h.0FFh ; 048h 
db 087h.0CFh.0CFh.0CFh.0CFh.0CFh.087h.0FFh ; 049h 
db 0E1h.0F3h.0F3h.0F3h.033h.033h.087h.0FFh ; 04Ah 
db 019h.099h.093h.087h.093h.099h.019h.0FFh ; 04Bh 
db 00Fh,09Fh,09Fh,09Fh,09Dh,099h.001h.0FFh ; 04Ch 
db 039h.011h.001h.001h.029h.039h.039h.0FFh ; 04Dh 
db 039h,019h,009h,021h,031h,039h, 039h,0FFh ; 04Eh 
db 0C7h,093h.039h,039h,039h.093h.0C7h.0FFh ; 04Fh 
db 003h.099h.099h.083h.09Fh.09Fh.00Fh.0FFh ; 050h 
db 087h.033h.033h.033h.023h.087h.0E3h.0FFh ; 051h 
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db 003h.099h,099h.083h,093h ( 099h,019h,0FFh ; 052h 
db 087h , 033h , 01 Fh , 08Fh , 0E3h , 033h , 087h, 0FFh ; 053h 
db 003h , 04Bh , 0CFh , 0CFh , 0CFh , 0CFh , 087h, 0FFh ; 054h 
db 033h,033h,033h,033h,033h,033h,003h,0FFh ; 055h 
db 033h,033h,033h,033h,033h,087h,0CFh,0FFh ; 056h 
db 039h,039h,039h,029h,001h,011h,039h,0FFh ; 057h 
db 039h,039h,093h,0C7h,0C7h,093h,039h.0FFh ; 058h 
db 033h , 033h , 033h , 087h ,0CFh , 0CFh , 087h,0FFh ; 059h 
db 001h,039h,073h,0E7h,0CDh,099h.001h,0FFh ; 05Ah 
db 087h,09Fh,09Fh,09Fh,09Fh,09Fh,087h,0FFh ; 05Bh 
db 03Fh,09Fh,0CFh,0E7h,0F3h,0F9h,0FDh,0FFh ; 05Ch 
db 087h,0E7h,0E7h,0E7h,0E7h,0E7h.087h,0FFh ; 05Dh 
db 0EFh , 0C7h , 093h, 039h , 0FFh, 0FFh , 0FFh , 0FFh ; 05Eh 
db 0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,000h ; 05Fh 
db 0CFh,0CFh,0E7h,0FFh,0FFh,0FFh,0FFh,0FFh ; 060h 
db 0FFh,0FFh,087h,0F3h,083h,033h,089h,0FFh ; 061h 
db 01Fh,09Fh,09Fh,083h,099h,099h,023h,0FFh ; 062h 
db 0FFh,0FFh,087h,033h,03Fh,033h,087h,0FFh ; 063h 
db 0E3h,0F3h,0F3h,083h.033h,033h,089h,0FFh ; 064h 
db 0FFh, 0FFh, 087h, 033h, 003h, 03Fh, 087h, 0FFh ; 065h 
db 0C7h,093h,09Fh,00Fh,09Fh,09Fh,00Fh,0FFh ; 066h 
db 0FFh , 0FFh, 089h, 033h , 033h , 083h , 0F3h, 007h ; 067h 
db 01Fh,09Fh,093h,089h,099h,099h,019h,0FFh ; 068h 
db 0CFh,0FFh,08Fh,0CFh,0CFh,0CFh,087h,0FFh ; 069h 
db 0F3h,0FFh,0F3h,0F3h,0F3h,033h,033h,087h ; 06Ah 
db 01Fh,09Fh,099h,093h,087h,093h,019h,0FFh ; 06Bh 
db 08Fh , 0CFh , 0CFh , 0CFh , 0CFh , 0CFh, 087h, 0FFh ; 06Ch 
db 0FFh,0FFh,033h,001h,001h.029h,039h,0FFh ; 06Dh 
db 0FFh , 0FFh , 007h, 033h , 033h , 033h , 033h , 0FFh ; 06Eh 
db 0FFh,0FFh,087h,033h,033h,033h,087h,0FFh ; 06Fh 
db 0FFh,0FFh,023h,099h,099h,083h,09Fh,00Fh ; 070h 
db 0FFh,0FFh,089h,033h,033h,083h,0F3h,0E1h ; 071h 
db 0FFh,0FFh,023h,089h,099h,09Fh,00Fh,0FFh ; 072h 
db 0FFh ,0FFh ,083h ,03Fh ,087h ,0F3h ,007h ,0FFh ; 073h 
db 0EFh ,0CFh ,083h ,0CFh ,0CFh ,0CBh ,0E7h,0FFh ; 074h 
db 0FFh,0FFh.033h,033h,033h,033h,089h,0FFh ; 075h 
db 0FFh , 0FFh , 033h , 033h , 033h , 087h , 0CFh , 0FFh ; 076h 
db 0FFh,0FFh.039h.029h.001h,001h,093h,0FFh ; 077h 
db 0FFh,0FFh,039h,093h,0C7h,093h,039h,0FFh ; 078h 
db 0FFh,0FFh,033h,033h,033h,083h,0F3h,007h ; 079h 
db 0FFh,0FFh,003h,067h,0CFh.09Bh,003h,0FFh ; 07Ah 
db 0E3h,0CFh,0CFh,01Fh,0CFh.0CFh,0E3h,0FFh ; 07Bh 
db 0E7h,0E7h,0E7h,0FFh,0E7h,0E7h,0E7h,0FFh : 07Ch 
db 01Fh,0CFh,0CFh,0E3h,0CFh,0CFh,01Fh,0FFh ; 07Dh 
db 089h,023h,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh j 07Eh 
db 0FFh,0EFh,0C7h,093h,039h,039h,001h,0FFh ; 07Fh 
db 087h,033h,03Fh,033h,087h,0E7h,0F3h,087h ; 080h 
db 0FFh,099h,0FFh,099h,099h,099h,0C0h,0FFh ; 081h 
db 0F1h,0FFh,0C3h,099h,081h,09Fh,0C3h,0FFh ; 082h 
db 081h,03Ch,0C3h,0F9h,0C1h,099h,0C0h,0FFh ; 083h 
db ©ggh.OFFh.OCSh.OFgh.OCIh.Oggh.OCOh^FFh ; 084h 
db 08Fh,0FFh,0C3h,0F9h,0C1h,099h,0C0h,0FFh ; 085h 
db 0E7h,0E7h,0C3h,0F9h,0C1h,099h,0C0h,0FFh ; 086h 
db 0FFh,0FFh,0C3h,09Fh,09Fh,0C3h,0F9h,0E3h ; 087h 
db 081h,03Ch.0C3h,099h.081h.09Fh,0C3h,0FFh ; 088h 
db 099h,0FFh,0C3h,099h.081h,09Fh,0C3h.0FFh ; 089h 
db 08Fh,0FFh,0C3h,099h,081h,09Fh,0C3h,0FFh ; 08Ah 
db 099h,0FFh,0C7h,0E7h,0E7h.0E7h,0C3h,0FFh ; 08Bh 
db 083h.039h,0C7h,0E7h.0E7h,0E7h,0C3h.0FFh ; 08Ch 
db 08Fh,0FFh,0C7h.0E7h,0E7h,0E7h,0C3h,0FFh ; 08Dh 
db OgCh.OESh.BCgh.OgCh.gsgh.ggCh.BgCh.OFFh ; 08Eh 
db 0E7h,0E7h,0FFh,0C3h,099h,081h,099h,0FFh ; 08Fh 
db 0F1h,0FFh,081h,0CFh,0C3h,0CFh,081h,0FFh ; 090h 
db 0FFh.0FFh.080h,0F3h.080h.033h.080h,0FFh ; 091h 
db 0E0h,0C9h.099h,080h,099h,099h,098h.0FFh ; 092h 
db 0C3h,099h,0FFh,0C3h,099h,099h,0C3h,0FFh ; 093h 
db ©FFh.oggh.oFFh.gcsh.gggh.gggh.gcsh.gFFh : 094h 
db 0FFh,08Fh,0FFh,0C3h,099h,099h,0C3h,0FFh ; 095h 
db 0C3h.099h,0FFh.099h.099h.099h,0C0h.0FFh ; 096h 
db 0FFh.08Fh,0FFh.099h,099h.099h,0C0h,0FFh ; 097h 
db gFFh.gggh.gFFh.gggh.gggh.gcih.gFgh.gssh ; 098h 
db 03Ch,0E7h,0C3h,099h,099h,0C3h,0E7h,0FFh ; 099h 
db 099h,0FFh,099h,099h,099h,099h.0C3h.0FFh ; 09Ah 
db 0E7h,0E7h,081h,03Fh,03Fh,081h,0E7h,0E7h ; 09Bh 
db 0E3h,0C9h,0CDh,087h,0CFh,08Ch,081h,0FFh ; 09Ch 


Continued) 
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db 099h.099h,0C3h,08ih,0E7h,08ih,0E7h,0E7h : 09Dh 

db 007h,033h.033h,005h,039h,030h,039h,038h ; 09Eh 

db 0F1h,0E4h,0E7h,0C3h,0E7h,0E7h,027h,08Fh ; 09Fh 

db 0F1h,0FFh.0C3h.0F9h,0C1h,099h,0C0h,0FFh ; 0A0h 

db 0E3h,0FFh,0C7h.0E7h,0E7h,0E7h,0C3h,0FFh j 0A1h 

db 0FFh,0F1h,0FFh,0C3H,099h,099h,0C3h,0FFh ; 0A2h 

db 0FFh,0F1h.0FFh,099h.099h,099h,0C0h,0FFh ; 0A3h 

db 0FFh,083h,0FFh,083h,099h,099h,099h,0FFh ; 0A4h 

db 081h,0FFh.099h,089h,081h.091h,099h,0FFh ; 0A5h 

db 0C3h,093h,093h,0C1h,0FFh,081h,0FFh,0FFh ; 0A6h 

db 0C7h,093h,093h,0C7h,0FFh,083h,0FFh,0FFh ; 0A7h 

db 0E7h,0FFh.0E7h,0CFh,09Fh,099h.0C3h,0FFh ; 0A8h 

db 0FFh,0FFh,0FFh,081h,09Fh,09Fh,0FFh,0FFh ; 0A9h 

db 0FFh,0FFh,0FFh,081h,0F9h,0F9h,0FFh,0FFh ; 0AAh 

db 03Ch,039h,033h,021h,0CCh,099h,033h,0F0h ; 0A8h 

db 03Ch,039h,033h ( 024h.0C8h.090h,030h,0FCh ; 0ACh 

db 0E7h,0E7h,0FFh,0E7h,0E7h,0E7h,0E7h,0FFh ; 0ADh 

db 0FFh.0CCh.099h.033h.099h.0CCh.0FFh.0FFh ; 0AEh 

db 0FFh,033h,099h,0CCh,099h,033h,0FFh,0FFh ; 0AFh 

db 0ODh,077h.0DDh,077h,0DDh,077h.0DDh,077h ; 0B0h 

db 0AAh , 055h , 0AAh , 055h, 0AAh , 055h , 0AAh , 055h ; 0B1h 

db 024h,088h,024h,011h,024h,088h,024h,011h ; 0B2h 

db 0E7h,0E7h,0E7h,0E7h,0E7h,0E7h,0E7h,0E7h ; 0B3h 

db 0E7h,0E7h,0E7H,0E7h,007h,0E7h,0E7h,0E7h ; 0B4h 

db 0E7h,0E7h,007h,0E7h,007h.0E7h,0E7h.0E7h ; 0B5h 

db 0C9h,0C9h,0C9h.0C9h,009h.0C9h,0C9h.0C9h ; 0B6h 

db 0FFh,0FFh,0FFh,0FFh,001h,0C9h,0C9h,0C9h ; 0B7h 

db 0FFh,0FFh,007h,0E7h,007h,0E7H,0E7h,0E7h ; 0B8h 

db 0C9h,0C9h.009h,0F9h,009h,0C9h,0C9h,0C9h ; ©B9h 

db 0C9h,0C9h,0C9h,0C9h,0C9h,0C9h.0C9h,0C9h : 0BAh 

db 0FFh.0FFh,001h,0F9h,009h,0C9h.0C9h,0C9h ; 0BBh 

db 0C9h,0C9h,009h,0F9h.001h,0FFh,0FFh,0FFh ; 0BCh 

db 0C9h,0C9h,0C9h,0C9h,001h,0FFh,0FFh,0FFh ; 0BDh 

db 0E7h,0E7h.007h,0E7h,007h,0FFh,0FFh.0FFh ; 0BEh 

db 0FFh,0FFh,0FFh,0FFh,007h,0E7h,0E7h,0E7h ; 0BFh 

db 0E7h,0E7h.0E7h,0E7h,0E0h.0FFh,0FFh,0FFh ; 0C0h 

db 0E7h,0E7h,0E7h,0E7h,000h,0FFh,0FFh,0FFh ; 0C1h 

db 0FFh , 0FFh , 0FFh , 0FFh, 000h , 0E7h , 0E7h , 0E7h ; 0C2h 

db 0E7h,0E7h,0E7h,0E7h,0E0h,0E7h,0E7h,0E7h ; 0C3h 

db 0FFh ,0FFh ,0FFh ,0FFh,000h ,0FFh ,0FFh ,0FFh ; 0C4h 

db 0E7h.0E7h.0E7h.0E7h.000h.0E7h.0E7h.0E7h ; 0C5h 

db 0E7h.0E7h.0E0h.0E7h.0E0h.0E7h.0E7h.0E7h ; 0C6h 

db 0C9h.0C9h,0C9h,0C9h.0C8h,0C9h,0C9h.0C9h ; 0C7h 

db 0C9h.0C9h.0C8h.0CFh.0C0h.0FFh.0FFh.0FFh ; 0C8h 

db 0FFh.0FFh.0C0h.0CFh.0C8h.0C9h.0C9h.0C9h ; 0C9h 

db 0C9h.0C9h.008h.0FFh.000h.0FFh.0FFh.0FFh ; 0CAh 

db 0FFh,0FFh,000h,0FFh.008h.0C9h,0C9h.0C9h ; 0CBh 

db 0C9h.0C9h.0C8h.0CFh.0C8h.0C9h.0C9h.0C9h ; 0CCh 

db 0FFh.0FFh.000h.0FFh.000h,0FFh,0FFh.0FFh ; 0CDh 

db 0C9h.0C9h.008h.0FFh.008h.0C9h.0C9h.0C9h ; 0CEh 

db 0E7h.0E7h.000h.0FFh.000h.0FFh.0FFh.0FFh ; 0CFh 

db 0C9h.0C9h.0C9h.0C9h.000h.0FFh.0FFh.0FFh ; 0D0h 

db 0FFh.0FFh.000h.0FFh.000h.0E7h.0E7h.0E7h ; 0D1h 

db 0FFh.0FFh.0FFh.0FFh.000h.0C9h.0C9h.0C9h ; 0D2h 

db 0C9h.0C9h.0C9h.0C9h.0C0h.0FFh.0FFh.0FFh ; 0D3h 

db 0E7h.0E7h.0E0h.0E7h.0E0h.0FFh.0FFh.0FFh ; 0D4h 

db 0FFh.0FFh.0E0h.0E7h.0E0h.0E7h.0E7h.0E7h ; 0D5h 

db 0FFh,0FFh,0FFh,0FFh,0C0h,0C9h.0C9h,0C9h ; 0O6h 

db 0C9h.0C9h.0C9h.0C9h.000h.0C9h.0C9h.0C9h ; 0D7h 

db 0E7h.0E7h.000h.0E7h.000h.0E7h.0E7h.0E7h ; 0D8h 

db 0E7h.0E7h.0E7h.0E7h.007h.0FFh.0FFh.0FFh ; 0D9h 

db 0FFh.0FFh.0FFh.0FFh.0E0h.0E7h.0E7h.0E7h ; 0DAh 

db 000h.000h.000h.000h.000h.000h.000h.000h ; 0DBh 

db 0FFh.0FFh.0FFh.0FFh.000h.000h.000h.000h ; 0DCh 

db 00Fh.00Fh,00Fh,00Fh.00Fh,00Fh.00Fh.00Fh ; 0DDh 

db 0F0h,0F0h.0F0h,0F0h,0F0h,0F0h,0F0h,0F0h ; 0DEh 

db 000h.000h,000h.000h,0FFh.0FFh,0FFh.0FFh ; 0DFh 

db 0FFh.0FFh.0C4h.091h.09Bh.091h.0C4h.0FFh ; 0E0h 

db 0FFh,0C3h,099h.083h,099h.083h,09Fh,09Fh ; 0E1h 

db 0FFh.081h,099h,09Fh,09Fh,09Fh,09Fh,0FFh ; 0E2h 

db 0FFh,080h.0C9h,0C9h,0C9h,0C9h.0C9h.0FFh ; 0E3h 

db 081h.099h.0CFh.0E7h.0CFh.099h.081h.0FFh ; 0E4h 

db 0FFh.0FFh.0C0h.093h.093h.093h.0C7h.0FFh ; 0E5h 

db 0FFh.0CCh.0CCh.0CCh.0CCh.0C1h.0CFh.09Fh ; 0E6h 

db 0FFh.0C4h.091h.0F3h.0F3h.0F3h.0F3h.0FFh ; 0E7h 

db 081h.0E7h.0C3h.099h.099h.0C3h.0E7h.081h ; 0E8h 
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db 0E3h,0C9h,09Ch,080h,09Ch,0C9h,0E3h,0FFh ; 0E9h 
db 0E3h,0C9h,09Ch,09Ch,0C9h,0C9h,088h,0FFh ; 0EAh 
db 0F1h, 0E7h,0F3h,0C1h, 099h, 099h, 0C3h,0FFh ; 0EBh 
db 0FFh, 0FFh,081h,024h, 024h, 081h,0FFh,0FFh ; 0ECh 
db 0F9h,0F3h,081h,024h, 024h, 081h,09Fh,03Fh ; 0EDh 
db 0E3h,09Fh,03Fh,003h,03Fh,09Fh,0E3h,0FFh ; 0EEh 
db 0C3h,099h,099h,099h,099h,099h,099h,0FFh ; 0EFh 
db 0FFh, 081h,0FFh,081h, 0FFh, 081h,0FFh,0FFh ; 0F0h 
db 0E7h, 0E7h,081h,0E7h,0E7h,0FFh,081h,0FFh ; 0F1h 
db 0CFh, 0E7h, 0F3h,0E7h,0CFh,0FFh,081h,0FFh ; 0F2h 
db 0F3h,0E7h,0CFh,0E7h,0F3h,0FFh,081h,0FFh ; 0F3h 
db 0F1h,0E4h,0E4h,0E7h,0E7h,0E7h,0E7h,0E7h ; 0F4h 
db 0E7h,0E7h,0E7h,0E7h,0E7h,027h,027h,08Fh ; 0F5h 
db 0E7h,0E7h,0FFh,081h,0FFh, 0E7h,0E7h, 0FFh ; 0F6h 
db 0FFh,089h,023h,0FFh,089h,023h.0FFh,0FFh ; 0F7h 
db 0C7h,093h,093h,0C7h,0FFh,0FFh,0FFh,0FFh ; 0F8h 
db 0FFh,0FFh,0FFh,0E7h,0E7h,0FFh,0FFh,0FFh ; 0F9h 
db 0FFh,0FFh,0FFh,0FFh,0E7h,0FFh,0FFh,0FFh ; 0FAh 
db 0F0h,0F3h,0F3h,0F3h,013h,093h,0C3h,0E3h ; 0FBh 
db 087h,093h,093h,093h,093h,0FFh,0FFh,0FFh ; 0FCh 
db 08Fh,0E7h,0CFh,09Fh,087h,0FFh,0FFh,0FFh ; 0FDh 
db 0FFh,0FFh,0C3h,0C3h,0C3h,0C3h,0FFh,0FFh ; 0FEh 
db 0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh ; 0FFh 


I abe11: 


; call BIOS to copy our definitions into character generator RAM area in 
; bit plane 2 


ES:BP points to our table 
CX :* number of characters defined 
in table 

DX character offset in table 
BL :« number of table to load (must 
be 0-3) 

BH :■ # bytes/character in table 
"user alpha load" 

BIOS "character generator routine" 
call EGA BIOS 



mov 

push 

pop 

mov 

bp,offset csdefs 
cs 

es 

cx,256 


mov 

mov 

dx ,0 
bl ,0 


mov 

mov 

mov 

Int 

bh ,8 
al,10h 
ah.llh 

10h 

; update BIOS 
mov 

mov 

RAM area in segment 40h 
ax,40h 
ds ,ax 


mov 

word ptr ds:[4Ah],80 


mov 

word ptr ds:[4Ch],1C00h 

; exit 

to DOS 
mov 
int 

ax,4C00h 

21h 

cseg 

ends 



end 

1abe10 


update CRT_C0LS (number of character 
columns on the display) 
update CRT_LEN (80 rows * 43 columns 
* 2 bytes/character, rounded up to 
next even IK boundary) 


CSLS5.ASM 

"RAM-Loadable Character Sets for the IBM PC," by 

Richard Wilton. Inside the IBM PCs, Extra Edition, page 197. 


title *256-character table for HGC Plus* 
name csls5 

page 55,132 


RAM-Loadable Character Sets for the IBM PC 
Listing 5 

(continued) 
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Notes: 

This program loads a 256-character definition table for use In 
alphanumeric video display modes. The program assumes 
that the proper video mode has already been established. 

The display Is configured for 80 character columns and 43 rows. 

For Hercules Graphics Card Plus ONLY. 


cseg segment para public ’CODE* 
assume cs:cseg,ds:cseg 

org 100h ; Initial program counter for .COM file 

Iabe10: 

jmp label 1 ; jump around character set table 

even 

; definitions for 8 by 8 characters 00h through FFh, with 8 bytes padding 


; between 

character definitions 


csdefs db 

000h,000h,000h,000h.000h,000h.000h,000h 

; 000h 

db 

8 dup(0) 


db 

07Eh,081h,0A5h.081h,0BDh,099h,081h,07Eh 

; 001h 

db 

8 dup(0) 


db 

07Eh,0FFh,0DBh,0FFh,0C3h,0E7h,0FFh,07Eh 

; 002h 

db 

8 dup(0) 


db 

06Ch,0FEh,0FEh,0FEh,07Ch.038h,010h.000h 

; 003h 

db 

8 dup(0) 


db 

010h,038h,07Ch,0FEh,07Ch,038h.010h.000h 

; 004h 

db 

8 dup(0) 


db 

038h,07Ch,038h,0FEh,0FEh,07Ch,038h,07Ch 

; 005h 

db 

8 dup(0) 


db 

010h,010h,038h,07Ch,0FEh,07Ch,038h.07Ch 

; 006h 

db 

8 dup(0) 


db 

000h,000h,018h,03Ch,03Ch,018h,000h,000h 

; 007h 

db 

8 dup(0) 


db 

0FFh.0FFh,0E7h.0C3h,0C3h,0E7h,0FFh,0FFh 

; 008h 

db 

8 dup(0) 


db 

000h,03Ch,066h,042h,042h,066h,03Ch,000h 

; 009h 

db 

8 dup(0) 


db 

0FFh,0C3h,099h,0BDh.0BDh,099h,0C3h,0FFh 

; 00Ah 

db 

8 dup(0) 


db 

00Fh,007h,00Fh,07Dh,0CCh,0CCh,0CCh,078h 

; 00Bh 

db 

8 dup(0) 


db 

03Ch,066h,066h,066h,03Ch,018h.07Eh,018h 

; 00Ch 

db 

8 dup(0) 


db 

03Fh,033h,03Fh,030h,030h.070h,0F0h,0E0h 

; 00Dh 

db 

8 dup(0) 


db 

07Fh,063h,07Fh.063h,063h # 067h.0E6h # 0C0h 

; 00Eh 

db 

8 dup(0) 


db 

099h,05Ah,03Ch,0E7h,0E7h,03Ch,05Ah,099h 

; 00Fh 

db 

8 dup(0) 


db 

080h,0E0h,0F8h,0FEh,0F8h,0E0h,080h,000h 

; 010h 

db 

8 dup(0) 


db 

002h,00Eh,03Eh,0FEh,03Eh,00Eh,002h,000h 

; 011h 

db 

8 dup(0) 


db 

018h,03Ch ( 07Eh,018h,018h,07Eh,03Ch,018h 

; 012h 

db 

8 dup(0) 


db 

066h t 066h,066h,066h,066h,000h,066h,000h 

; 013h 

db 

8 dup(0) 


db 

07Fh,0DBh,0DBh,07Bh,01Bh,01Bh,01Bh,000h 

; 014h 

db 

8 dup(0) 


db 

03Eh,063h,038h,06Ch,06Ch.038h,0CCh,078h 

; 015h 

db 

8 dup(0) 


db 

000h,000h,000h,000h,07Eh,07Eh,07Eh,000h 

; 016h 

db 

8 dup(0) 


db 

018h,03Ch.07Eh,018h,07Eh,03Ch,018h,0FFh 

; 017h 

db 

8 dup(0) 


db 

018h,03Ch,07Eh,018h,018h,018h,018h,000h 

; 018h 
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db 

db 

8 dup(0) 

018h,018h,018h,018h,07Eh, 03Ch,018h,000h 

; 019h 

db 

db 

8 dup(0) 

000h,018h,00Ch,0FEh,00Ch,018h,000h,000h 

; 01 Ah 

db 

db 

8 dup(0) 

000h,030h,060h,0FEh # 060h,030h,000h,000h 

; 01Bh 

db 

db 

8 dup(0) 

000h,000h,0C0h,0C0h,0C0h,0FEh,000h,000h 

; 01Ch 

db 

db 

8 dup(0) 

000h,024h,066h,0FFh,066h,024h,000h,000h 

; 01Dh 

db 

db 

8 dup(0) 

000h,018h.03Ch,07Eh,0FFh,0FFh,000h,000h 

; 01Eh 

db 

db 

8 dup(0) 

000h,0FFh,0FFh,07Eh,03Ch,018h ,000h,000h 

; 01Fh 

db 

db 

8 dup(0) 

000h,000h,000h,000h,000h,000h,000h,000h 

; 020h 

db 

db 

8 dup(0) 

030h,078h,078h,030h,030h,000h,030h,000h 

; 021h 

db 

db 

8 dup(0) 

06Ch,06Ch,06Ch,000h,000h,000h,000h,000h 

; 022h 

db 

db 

8 dup(0) 

06Ch,06Ch,0FEh,06Ch,0FEh,06Ch,06Ch,000h 

; 023h 

db 

db 

8 dup(0) 

030h,07Ch,0C0h,078h,00Ch,0F8h,030h,000h 

; 024h 

db 

db 

8 dup(0) 

000h,0C6h,0CCh # 018h,030h.066h,0C6h,000h 

; 025h 

db 

db 

8 dup(0) 

038h,06Ch,038h,076h,0DCh,0CCh,076h,000h 

; 026h 

db 

db 

8 dup(0) 

060h,060h,0C0h,000h,000h,000h,000h,000h 

; 027h 

db 

db 

8 dup(0) 

018h,030h,060h,060h,060h,030h,018h,000h 

; 028h 

db 

db 

8 dup(0) 

060h,030h,018h,018h,018h,030h,060h,000h 

; 029h 

db 

db 

8 dup(0) 

000h,066h,03Ch,0FFh,03Ch,066h,000h,000h 

; 02Ah 

db 

db 

8 dup(0) 

000h,030h,030h,0FCh,030h,030h,000h,000h 

; 02Bh 

db 

db 

8 dup(0) 

000h,000h,000h,000h,000h,030h,030h,060h 

; 02Ch 

db 

db 

8 dup(0) 

000h,000h,000h,0FCh,000h,000h,000h,000h 

; 02Dh 

db 

db 

8 dup(0) 

000h,000h,000h,000h,000h,030h,030h,000h 

; 02Eh 

db 

db 

8 dup(0) 

006h,00Ch,018h,030h,060h,0C0h,080h,000h 

; 02Fh 

db 

db 

8 dup(0) 

07Ch,0C6h,0CEh,0DEh,0F6h,0E6h,07Ch,000h 

; 030h 

db 

db 

8 dup(0) 

030h,070h,030h,030h,030h,030h,0FCh,000h 

; 031h 

db 

db 

8 dup(0) 

078h,0CCh,00Ch,038h,060h,0CCh,0FCh,000h 

; 032h 

db 

db 

8 dup(0) 

078h,0CCh.00Ch,038h # 00Ch,0CCh,078h,000h 

; 033h 

db 

db 

8 dup(0) 

01Ch.03Ch,06Ch,0CCh,0FEh,00Ch,01Eh,000h 

; 034h 

db 

db 

8 dup(0) 

0FCh,0C0h,0F8h,00Ch,00Ch,0CCh,078h,000h 

; 035h 

db 

db 

8 dup(0) 

038h,060h,0C0h,0F8h,0CCh,0CCh,078h,000h 

; 036h 

db 

db 

8 dup(0) 

0FCh,0CCh,00Ch,018h,030h,030h,030h,000h 

; 037h 

db 

db 

8 dup(0) 

078h,0CCh,0CCh,078h,0CCh.0CCh.078h,000h 

; 038h 

db 

db 

8 dup(0) 

078h,0CCh,0CCh,07Ch,00Ch,018h,070h,000h 

; 039h 

db 

db 

8 dup(0) 

000h,030h,030h,000h,000h,030h,030h,000h 

; 03Ah 

db 

db 

8 dup(0) 

000h,030h,030h,000h,000h,030h,030h,060h 

; 03Bh 

db 

db 

8 dup(0) 

018h,030h,060h.0C0h,060h,030h,018h,000h 

; 03Ch 

db 

db 

8 dup(0) 

000h,000h,0FCh # 000h,000h,0FCh,000h,000h 

; 03Dh 

db 

8 dup(0) 
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db 

db 

060h , 030h. 018h. 00Ch . 018h. 030h. 060h, 000h 

8 dup(0) 

; 03Eh 

db 

db 

078h,0CCh,00Ch.018h,030h,000h,030h,000h 

8 dup(0) 

; 03Fh 

db 

db 

07Ch,0C6h.0DEh,0DEh.0DEh,0C0h,078h.000h 

8 dup(0) 

; 040h 

db 

db 

030h,078h,0CCh.0CCh,0FCh,0CCh.0CCh,000h 

8 dup(0) 

; 041h 

db 

db 

0FCh,066h,066h.07Ch.066h,066h,0FCh,000h 

8 dup(0) 

; 042h 

db 

db 

03Ch.066h,0C0h,0C0h,0C0h.066h.03Ch,000h 

8 dup(0) 

; 043h 

db 

db 

0F8h,06Ch,066h.066h,066h.06Ch.0F8h.000h 

8 dup(0) 

; 044h 

db 

db 

0FEh,062h.068h,078h,068h,062h.0FEh,000h 

8 dup(0) 

; 045h 

db 

db 

0FEh,062h.068h,078h.068h,060h,0F0h,000h 

8 dup(0) 

; 046h 

db 

db 

03Ch,066h,0C0h,0C0h,0CEh,066h,03Eh,000h 

8 dup(0) 

; 047h 

db 

db 

0CCh,0CCh.0CCh,0FCh,0CCh,0CCh,0CCh,000h 

8 dup(0) 

; 048h 

db 

db 

078h . 030h. 030h . 030h , 030h , 030h . 078h , 000h 

8 dup(0) 

; 049h 

db 

db 

01Eh.00Ch,00Ch,00Ch.0CCh,0CCh.078h,000h 

8 dup(0) 

; 04Ah 

db 

db 

0E6h.066h.06Ch.078h,06Ch.066h,0E6h.000h 

8 dup(0) 

; 04Bh 

db 

db 

0F0h , 060h , 060h . 060h, 062h . 066h, 0FEh, 000h 

8 dup(0) 

; 04Ch 

db 

db 

0C6h,0EEh,0FEh.0FEh,0D6h.0C6h,0C6h.000h 

8 dup(0) 

; 04Dh 

db 

db 

0C6h.0E6h,0F6h,0DEh,0CEh,0C6h,0C6h,000h 

8 dup(0) 

; 04Eh 

db 

db 

038h,06Ch,0C6h,0C6h,0C6h,06Ch,038h,000h 

8 dup(0) 

; 04Fh 

db 

db 

0FCh.066h,066h,07Ch,060h,060h,0F0h,000h 

8 dup(0) 

; 050h 

db 

db 

078h,0CCh.0CCh,0CCh.0OCh.078h,01Ch,00Oh 

8 dup(0) 

; 051 h 

db 

db 

0FCh,066h,066h,07Ch,06Ch,066h,0E6h,000h 

8 dup(0) 

; 052h 

db 

db 

078h , 0CCh , 0E0h . 070h , 01 Ch , 0CCh . 078h, 000h 

8 dup(0) 

; 053h 

db 

db 

0FCh,0B4h,030h,030h,030h.030h.078h.000h 

8 dup(0) 

; 054h 

db 

db 

0CCh,0CCh,0CCh.0CCh.0CCh,0CCh,0FCh,000h 

8 dup(0) 

; 055h 

db 

db 

0CCh,0CCh,0CCh,0CCh,0CCh,078h,030h,000h 

8 dup(0) 

; 056h 

db 

db 

0C6h,0C6h,0C6h,0O6h,0FEh.0EEh,0C6h,000h 

8 dup(0) 

; 057h 

db 

db 

0C6h.0C6h,06Ch,038h.038h,06Ch,0C6h,000h 

8 dup(0) 

; 058h 

db 

db 

0CCh, 0CCh, 0CCh. 078h, 030h, 030h, 078h, 000h 

8 dup(0) 

; 059h 

db 

db 

0FEh,0C6h,08Ch,018h.032h,066h,0FEh,000h 

8 dup(0) 

; 05Ah 

db 

db 

078h.060h,060h,060h,060h,060h,078h,000h 

8 dup(0) 

; 05Bh 

db 

db 

0C0h,060h,030h.018h,00Ch,006h.002h,000h 

8 dup(0) 

; 05Ch 

db 

db 

078h , 018h , 018h . 018h. 018h . 018h . 078h, 000h 

8 dup(0) 

; 05Dh 

db 

db 

010h,038h,06Ch,0C6h,000h,000h,000h,000h 

8 dup(0) 

; 05Eh 

db 

db 

000h, 000h , 000h . 000h, 000h , 000h. 000h, 0FFh 

8 dup(0) 

; 05Fh 

db 

db 

030h , 030h , 018h , 000h , 000h , 000h . 000h , 000h 

8 dup(0) 

; 060h 

db 

db 

000h,000h.078h,00Ch,07Ch.0CCh,076h,000h 

8 dup(0) 

; 061h 

db 

db 

0E0h,060h,060h,07Ch,066h,066h,0DCh,000h 

8 dup(0) 

; 062h 

db 

db 

000h, 000h , 078h , 0CCh. 0C0h , 0CCh , 078h , 000h 

8 dup(0) 

; 063h 
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db 

01Ch,00Ch,00Ch,07Ch,0CCh,0CCh,076h,000h 

; 064h 

db 

8 dup(0) 


db 

000h,000h,078h,0CCh,0FCh # 0C0h,078h,000h 

; 065h 

db 

8 dup(0) 


db 

038h,06Ch,060h,0F0h,060h,060h,0F0h,000h 

; 066h 

db 

8 dup(0) 


db 

000h,000h,076h,0CCh,0CCh,07Ch,00Ch,0F8h 

; 067h 

db 

8 dup(0) 


db 

0E0h,060h,06Ch,076h,066h,066h,0E6h,000h 

; 068h 

db 

8 dup(0) 


db 

030h,000h,070h,030h,030h,030h,078h,000h 

; 069h 

db 

8 dup(0) 


db 

00Ch,000h,00Ch,00Ch,00Ch,0CCh,0CCh,078h 

; 06Ah 

db 

8 dup(0) 


db 

0E0h,060h,066h,06Ch,078h,06Ch,0E6h,000h 

; 06Bh 

db 

8 dup(0) 


db 

070h,030h,030h,030h,030h,030h,078h.000h 

; 06Ch 

db 

8 dup(0) 


db 

000h,000h,0CCh,0FEh,0FEh,0D6h,0C6h,000h 

; 06Dh 

db 

8 dup(0) 


db 

000h,000h,0F8h,0CCh,0CCh,0CCh,0CCh,000h 

; 06Eh 

db 

8 dup(0) 


db 

000h,000h,078h,0CCh,0CCh,0CCh,078h,000h 

; 06Fh 

db 

8 dup(0) 


db 

000h,000h,0DCh,066h,066h,07Ch,060h,0F0h 

; 070h 

db 

8 dup(0) 


db 

000h,000h,076h,0CCh,0CCh,07Ch,00Ch,01Eh 

; 071h 

db 

8 dup(0) 


db 

000h,000h,0DCh,076h,066h,060h,0F0h,000h 

; 072h 

db 

8 dup(0) 


db 

000h,000h,07Ch,0C0h,078h.00Ch,0F8h,000h 

; 073h 

db 

8 dup(0) 


db 

010h.030h,07Ch,030h,030h,034h,018h,000h 

; 074h 

db 

8 dup(0) 


db 

000h,000h,0CCh,0CCh,0CCh,0CCh,076h,000h 

; 075h 

db 

8 dup(0) 


db 

000h,000h,0CCh,0CCh,0CCh,078h,030h,000h 

; 076h 

db 

8 dup(0) 


db 

000h.000h,0C6h,0D6h,0FEh,0FEh,06Ch,000h 

; 077h 

db 

8 dup(0) 


db 

000h,000h,0C6h,06Ch,038h,06Ch,0C6h,000h 

; 078h 

db 

8 dup(0) 


db 

000h,000h,0CCh.0CCh,0CCh,07Ch,00Ch.0F8h 

; 079h 

db 

8 dup(0) 


db 

000h,000h,0FCh,098h,030h,064h,0FCh,000h 

; 07Ah 

db 

8 dup(0) 


db 

0ICh,030h,030h,0E0h,030h,030h,01Ch,000h 

; 07Bh 

db 

8 dup(0) 


db 

018h,018h,018h,000h,018h,018h,018h,000h 

; 07Ch 

db 

8 dup(0) 


db 

0E0h,030h,030h,01Ch,030h # 030h,0E0h,000h 

; 07Dh 

db 

8 dup(0) 


db 

076h,0DCh,000h,000h,000h,000h,000h,000h 

; 07Eh 

db 

8 dup(0) 


db 

000h,010h # 038h,06Ch,0C6h,0C6h,0FEh,000h 

; 07Fh 

db 

8 dup(0) 


db 

078h,0CCh,0C0h,0CCh,078h,018h,00Ch,078h 

; 080h 

db 

8 dup(0) 


db 

000h 1 066h,000h,066h,066h,066h,03Fh,000h 

; 081h 

db 

8 dup(0) 


db 

00Eh,000h,03Ch,066h,07Eh,060h,03Ch,000h 

; 082h 

db 

8 dup(0) 


db 

07Eh 1 0C3h,03Ch,006h,03Eh # 066h,03Fh,000h 

; 083h 

db 

8 dup(0) 


db 

066h,000h,03Ch,006h,03Eh,066h,03Fh,000h 

; 084h 

db 

8 dup(0) 


db 

070h,000h,03Ch,006h,03Eh,066h,03Fh,000h 

; 085h 

db 

8 dup(0) 


db 

018h,018h,03Ch,006h,03Eh ( 066h,03Fh # 000h 

; 086h 

db 

8 dup(0) 


db 

000h,000h,03Ch,060h,060h,03Ch,006h,01Ch 

; 087h 

db 

8 dup(0) 


db 

07Eh,0C3h,03Ch,066h,07Eh,060h,03Ch,000h 

; 088h 

db 

8 dup(0) 


db 

066h,000h,03Ch,066h,07Eh,060h,03Ch,000h 

; 089h 
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db 

8 dup(0) 


db 

070h,000h,03Ch,066h,07Eh,060h,03Ch,000h 

; 08Ah 

db 

8 dup(0) 


db 

066h,000h,038h,018h,018h,018h.03Ch,000h 

; 08Bh 

db 

8 dup(0) 


db 

07Ch,0C6h,038h,018h,018h,018h,03Ch,000h 

; 08Ch 

db 

8 dup(0) 


db 

070h,000h,038h,018h,018h,018h,03Ch,000h 

; 08Dh 

db 

8 dup(0) 


db 

063h,01Ch,036h,063h,07Fh,063h,063h,000h 

; 08Eh 

db 

8 dup(0) 


db 

018h.018h,000h,03Ch,066h,07Eh,066h,000h 

; 08Fh 

db 

8 dup(0) 


db 

00Eh,000h,07Eh,030h,03Ch,030h,07Eh,000h 

; 090h 

db 

8 dup(0) 


db 

000h,000h.07Fh,00Ch.07Fh,0CCh # 07Fh,000h 

; 091h 

db 

8 dup(0) 


db 

01Fh,036h,066h,07Fh,066h,066h,067h,000h 

; 092h 

db 

8 dup(0) 


db 

03Ch,066h,000h,03Ch,066h,066h,03Ch,000h 

; 093h 

db 

8 dup(0) 


db 

000h,066h,000h,03Ch,066h,066h,03Ch,000h 

; 094h 

db 

8 dup(0) 


db 

000h,070h,000h,03Ch,066h,066h,03Ch,000h 

; 095h 

db 

8 dup(0) 


db 

03Ch,066h,000h,066h,066h,066h,03Fh,000h 

; 096h 

db 

8 dup(0) 


db 

000h,070h,000h,066h,066h,066h,03Fh,000h 

; 097h 

db 

8 dup(0) 


db 

000h,066h,000h,066h,066h,03Eh,006h.07Ch 

; 098h 

db 

8 dup(0) 


db 

0C3h,018h,03Ch,066h,066h,03Ch,018h,000h 

; 099h 

db 

8 dup(0) 


db 

066h,000h,066h,066h,066h,066h,03Ch,000h 

; 09Ah 

db 

8 dup(0) 


db 

018h,018h,07Eh,0C0h,0C0h,07Eh,018h,018h 

; 09Bh 

db 

8 dup(0) 


db 

01Ch,036h,032h,078h,030h,073h,07Eh,000h 

; 09Ch 

db 

8 dup(0) 


db 

066h,066h,03Ch,07Eh,018h,07Eh,018h,018h 

; 09Dh 

db 

8 dup(0) 


db 

0F8h,0CCh,0CCh,0FAh,0C6h,0CFh,0C6h,0C7h 

; 09Eh 

db 

8 dup(0) 


db 

00Eh,01Bh,018h,03Ch,018h,018h,0D8h,070h 

; 09Fh 

db 

8 dup(0) 


db 

00Eh,000h,03Ch,006h,03Eh,066h,03Fh,000h 

; 0A0h 

db 

8 dup(0) 


db 

01Ch,000h,038h,018h,018h,018h,03Ch,000h 

; 0A1 h 

db 

8 dup(0) 


db 

000h,00Eh,000h,03Ch,066h,066h,03Ch,000h 

; 0A2h 

db 

8 dup(0) 


db 

000h,00Eh,000h,066h,066h,066h,03Fh,000h 

; 0A3h 

db 

8 dup(0) 


db 

000h,07Ch,000h,07Ch,066h,066h,066h,000h 

; 0A4h 

db 

8 dup(0) 


db 

07Eh,000h,066h,076h,07Eh,06Eh,066h,000h 

; 0A5h 

db 

8 dup(0) 


db 

03Ch,06Ch,06Ch,03Eh,000h,07Eh,000h,000h 

; 0A6h 

db 

8 dup(0) 


db 

038h,06Ch,06Ch,038h,000h,07Ch,000h,000h 

; 0A7h 

db 

8 dup(0) 


db 

018h,000h,018b,030h,060h,066h,03Ch,000h 

; 0A8h 

db 

8 dup(0) 


db 

000h,000h,000h,07Eh,060h,060h,000h,000h 

; 0A9h 

db 

8 dup(0) 


db 

000h,000h,000h,07Eh,006h,006h,000h,000h 

; 0AAh 

db 

8 dup(0) 


db 

0C3h,0C6h,0CCh,0DEh,033h,066h,0CCh,00Fh 

; 0ABh 

db 

8 dup(0) 


db 

0C3h.0C6h,0CCh,0DBh,037h,06Fh,0CFh,003h 

; 0ACh 

db 

8 dup(0) 


db 

018h,018h,000h,018h,018h,018h,018h,000h 

; 0ADh 

db 

8 dup(0) 


db 

000h,033h,066h,0CCh,066h,033h,000h,000h 

; 0AEh 

db 

8 dup(0) 


db 

000h,0CCh,066h,033h,066h,0CCh,000h,000h 

; 0AFh 
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db 

db 

8 dup(0) 

022h, 088h , 022h , 088h , 022h , 088h , 022h, 088h 

; 0B0h 

db 

db 

8 dup(0) 

055h , 0AAh , 055h, 0AAh , 055h , 0AAh , 055h. 0AAh 

; 0B1h 

db 

db 

8 dup(0) 

0DBh.077h,0DBh,0EEh,0DBh,077h,0DBh,0EEh 

; 0B2h 

db 

db 

8 dup(0) 

018h,018h,018h,018h,018h,018h,018h,018h 

; 0B3h 

db 

db 

8 dup(0) 

018h,018h,018h,018h,0F8h,018h,018h,018h 

; 0B4h 

db 

db 

8 dup(0) 

018h,018h,0F8h,018h,0F8h,018h,018h,018h 

; 0B5h 

db 

db 

8 dup(0) 

036h,036h,036h.036h,0F6h,036h,036h,036h 

; 0B6h 

db 

db 

8 dup(0) 

000h,000h,000h,000h,0FEh,036h,036h,036h 

; 0B7h 

db 

db 

8 dup(0) 

000h,000h,0F8h,018h,0F8h,018h,018h,018h 

; 0B8h 

db 

db 

8 dup(0) 

036h.036h,0F6h,006h,0F6h,036h,036h.036h 

; 0B9h 

db 

db 

8 dup(0) 

036h,036h,036h,036h,036h,036h,036h,036h 

; 0BAh 

db 

db 

8 dup(0) 

000h.000h,0FEh,006h,0FSh,036h,036h.036h 

; 0BBh 

db 

db 

8 dup(0) 

036h,036h.0F6h,006h,0FEh,000h,000h,000h 

; 0BCh 

db 

db 

8 dup(0) 

036h,036h,036h,036h,0FEh.000h,000h,000h 

; 0BDh 

db 

db 

8 dup(0) 

018h,018h,0F8h.018h,0F8h,000h,000h,000h 

; 0BEh 

db 

db 

8 dup(0) 

000h,000h,000h,000h,0F8h,018h,018h,018h 

; 0BFh 

db 

db 

8 dup(0) 

018h.018h,018h,018h,01Fh,000h,000h.000h 

; 0C0h 

db 

db 

8 dup(0) 

018h , 018h . 018h , 018h, 0FFh , 000h , 000h . 000h 

; 0C1 h 

db 

db 

8 dup(0) 

000h,000h,000h,000h,0FFh,018h,018h,018h 

; 0C2h 

db 

db 

8 dup(0) 

01811,01811,018^01811,0^,01811,01811,01811 

; 0C3h 

db 

db 

8 dup(0) 

000h,000h,000h,000h,0FFh,000h,000h,000h 

; 0C4h 

db 

db 

8 dup(0) 

018h,018h,018h,018h.0FFh,018h,018h,018h 

; 0C5h 

db 

db 

8 dup(0) 

018h ,018h ,01Fh ,018h ,01Fh ,018h ,018h ,018h 

; 0C6h 

db 

db 

8 dup(0) 

036h,036h,036h,036h,037h.036h,036h,036h 

; 0C7h 

db 

db 

8 dup(0) 

036h,036h.037h,030h,03Fh,000h,000h,000h 

; 0C8h 

db 

db 

8 dup(0) 

000h,000h,03Fh,030h,037h,036h,036h.036h 

; 0C9h 

db 

db 

8 dup(0) 

03$h,036h,0F7h,000h,0FFh,000h,000h,000h 

; 0CAh 

db 

db 

8 dup(0) 

000h,000h,0FFh,000h,0F7h.036h,036h,03Sh 

; 0CBh 

db 

db 

8 dup(0) 

036h,036h,037h,030h,037h,036h,036h,036h 

; 0CCh 

db 

db 

8 dup(0) 

000h,000h,0FFh.000h,0FFh,000h,000h,000h 

; 0CDh 

db 

db 

8 dup(0) 

036h,036h,0F7h,000h,0F7h,036h.036h,036h 

; 0CEh 

db 

db 

8 dup(0) 

018h . 018h , 0FFh , 000h ,0FFh , 000h , 000h , 000h 

; 0CFh 

db 

db 

8 dup(0) 

036h,036h,036h,036h,0FFh,000h,000h,000h 

; 0D0h 

db 

db 

8 dup(0) 

000h,000h.0FFh.000h,0FFh.018h,018h,018h 

; 0D1 h 

db 

db 

8 dup(0) 

000h,000h,000h,000h,0FFh,036h.036h,036h 

; 0D2h 

db 

db 

8 dup(0) 

036h,036h,036h,036h,03Fh,000h,000h.000h 

; 0D3h 

db 

db 

8 dup(0) 

018h ,018h ,01Fh ,018h ,01Fh , 000ti ,000h ,000h 

; 0D4h 


db 8 dup(0) 
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db 

db 

eeeh.eeeh.eirh.eish.eiFh.eish.eish.eish 

8 dup(0) 

; 0D5h 

db 

db 

000h,000h.000h,000h,03Fh,036h,036h,036h 

8 dup(0) 

; 0D6h 

db 

db 

036h.036h,036h.036h,0FFh,036h.036h,036h 

8 dup(0) 

; 0D7h 

db 

db 

©ISh.OISh.eFFh.OISh.OFFh.OISh^lSh.OISh 

8 dup(0) 

; 0D8h 

db 

db 

018h,018h,018h,018h,0F8h,000h,000h,000h 

8 dup(0) 

; 0D9h 

db 

db 

000h,000h,000h.000h,01Fh,018h,018h,018h 

8 dup(0) 

; 0DAh 

db 

db 

0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,0FFh 

8 dup(0) 

; 0DBh 

db 

db 

000h,000h,000h,000h,0FFh,0FFh,0FFh,0FFh 

8 dup(0) 

; 0DCh 

db 

db 

0F0h,0F0h,0F0h,0F0h,0F0h,0F0h,0F0h,0F0h 

8 dup(0) 

; 0DDh 

db 

db 

00Fh,00Fh.00Fh,00Fh,00Fh,00Fh.00Fh,00Fh 

8 dup(0) 

; 0DEh 

db 

db 

0FFh. 0FFh , 0FFh , 0FFh. 000h , 000h , 000h, 000h 

8 dup(0) 

; 0DFh 

db 

db 

000h,000h,03Bh,0$Eh,064h,06Eh,03Bh,000h 

8 dup(0) 

; 0E0h 

db 

db 

000h , 03Ch . 066h , 07Ch, 066h , 07Ch . 060h. 060h 

8 dup(0) 

; 0E1h 

db 

db 

000h , 07Eh . 066h . 060h. 060h , 060h , 060h. 000h 

8 dup(0) 

; 0E2h 

db 

db 

000h,07Fh.036h.036h,036h.036h,036h,000h 

8 dup(0) 

; 0E3h 

db 

db 

07Eh,066h.030h.018h,030h,066h,07Eh,000h 

8 dup(0) 

; 0E4h 

db 

db 

000h,000h.03Fh,06Ch,06Ch.06Ch,038h,000h 

8 dup(0) 

; 0E5h 

db 

db 

000h,033h,033h,033h.033h.03Eh,030h.060h 

8 dup(0) 

; 0E6h 

db 

db 

000h, 03Bh. 06Eh, 00Ch, 00Ch, 00Ch, 00Ch. 000h 

8 dup(0) 

; 0E7h 

db 

db 

07Eh,018h,03Ch,066h,066h,03Ch,018h,07Eh 

8 dup(0) 

; 0E8h 

db 

db 

0ICh . 036h , 063h , 07Fh . 063h . 036h , 0ICh . 000h 

8 dup(0) 

; 0E9h 

db 

db 

01Ch,036h,063h,063h.036h,036h,077h,000h 

8 dup(0) 

; 0EAh 

db 

db 

00Eh, 018h , 00Ch , 03Eh . 066h , 066h , 03Ch , 000h 

8 dup(0) 

; 0EBh 

db 

db 

000h, 000h , 07Eh . 0DBh, 0OBh , 07Eh , 000h , 000h 

8 dup(0) 

; 0ECh 

db 

db 

006h,00Ch,07Eh,0DBh,0DBh,07Eh.060h,0C0h 

8 dup(0) 

; 0EDh 

db 

db 

01Ch,060h.0C0h,0FCh,0C0h,060h,01Ch,000h 

8 dup(0) 

; 0EEh 

db 

db 

03Ch,066h,066h,066h.066h,066h,066h,000h 

8 dup(0) 

; 0EFh 

db 

db 

000h, 07Eh, 000h, 07Eh, 000h, 07Eh. 000h, 000h 

8 dup(0) 

; 0F0h 

db 

db 

018h , 018h , 07Eh , 018h , 018h , 000h , 07Eh , 000h 

8 dup(0) 

; 0F1h 

db 

db 

030h.018h.00Ch.018h.030h,000h.07Eh,000h 

8 dup(0) 

; 0F2h 

db 

db 

00Ch, 018h , 030h , 018h, 00Ch . 000h , 07Eh, 000h 

8 dup(0) 

; 0F3h 

db 

db 

©OEh.OIBh.OIBh.OISh^lSh^lSh.OISh.OISh 

8 dup(0) 

; 0F4h 

db 

db 

018h,018h,018h,018h,018h,0O8h,0D8h,070h 

8 dup(0) 

; 0F5h 

db 

db 

018h, 018h , 000h , 07Eh , 000h . 018h , 018h . 000h 

8 dup(0) 

; 0F6h 

db 

db 

000h. 076h , 0DCh , 000h. 076h , 0DCh , 000h, 000h 

8 dup(0) 

; 0F7h 

db 

db 

038h,0SCh.06Ch,038h,000h,000h,000h,000h 

8 dup(0) 

; 0F8h 

db 

db 

000h,000h,000h,018h,018h,000h,000h,000h 

8 dup(0) 

; 0F9h 

db 

db 

000h, 000h, 000h, 000h. 018h, 000h, 000h. 000h 

8 dup(0) 

; 0FAh 
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db 

00Fh , 00Ch , 00Ch . 00Ch , 0ECh , 06Ch, 03Ch , 01Ch 

; 0FBh 

db 

8 dup(0) 


db 

078h,06Ch.06Ch,06Ch,06Ch,000h,000h,000h 

; 0FCh 

db 

8 dup(0) 


db 

070h. 018h , 030h , 060h , 078h , 000h , 000h, 000h 

; 0FDh 

db 

8 dup(0) 


db 

000h,000h,03Ch,03Ch,03Ch,03Ch,000h,000h 

; 0FEh 

db 

8 dup(0) 


db 

000h.000h,000h.000h,000h,000h,000h,000h 

; 0FFh 

db 

8 dup(0) 



Iabe 11: 

; set configuration switch on HGC Plus 


mov 

dx,3BFh 

; i/o port address 

mov 

a 1 ,1 

; activate RAM from B000-.0000 

out 

dx.al 

; through B000:7FFF 

copy character definition table to 

B000:4000 

mov 

ax,0B000h 


mov 

es, ax 


mov 

di,4000h 

; ES:DI :« B000:4000 

push 

cs 


pop 

ds 


mov 

si.offset csdefs 

; DS:SI -> our character def table 

mov 

cx,1abe11-csdefs 

; CX := size of table in bytes 

rep 

movsb 

; copy the table 

; Program the 

CRT controller to display 43 lines of 8 by 8 characters. 

; Characters are displayed in a 9x8 

matrix for better appearance. 

mov 

dx,3B4h 

; CRT controller register index port 

mov 

si,offset regs00_0D 

; DS:SI -> start of table of register 



; values 

mov 

cx,0Eh 

; CX :* loop counter 

xor 

ah ,ah 

; AH :■ 0 (Initial CRT controller 



; register number) 

1abeI2: mov 

a 1 , ah 


out 

dx, a 1 

; store CRT controller Index reg 

lodsb 


; AL :* data for CRT controller reg 

i nc 

dx 

; DX 3B5h (CRT data reg port) 

out 

dx, a 1 

; store data to CRT controller reg 

dec 

dx 

; DX 3B4h 

i nc 

ah 

; AH :*= next CRT controller index # 

loop 

1abe12 


mov 

a 1,14h 

; xModeReg index number 

out 

dx.al 


lodsb 



i nc 

dx 


out 

dx, a 1 

; configure xModeReg for RAM character 


set and proper character width 


; update BIOS RAM area In segment 40h 
mov ax,40h 

mov ds.ox 


mov word ptr ds:r4Ahl,80 

mov word ptr ds:L4ChJ,1C00h 


; exit to DOS 

mov ax,4C00h 

Int 21h 


update CRT_COLS (80 columns) 
update CRT_LEN (80 columns * 43 rows 
* 2 bytes/character, rounded up to 
even IK boundary) 


; table of CRT controller register values 
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regs00_0D 

db 

61h.50h.52h.0rh 


db 

2Oh.02h.2Bh.2Ch 


db 

02h,07h,06h,07h 


db 

00h,00h 

xModeReg 

db 

01h 

cseg ends 

end 

1abe10 



; regs 0 - 3 (9 wide) 

; regs 4 - 7 (8 high) 

; regs 8 - 0Bh (scans/char, 

; cursor location) 

; regs 0Ch - 0Dh (always zero) 

; "4K RamFont", 9 dot wide 
; characters 


CSLS6.ASM 

"RAM-Loadable Character Sets for the IBM PC," by 
Richard Wilton. Inside the IBM PCs, Extra Edition, page 197. 


title ’extended character set for the EGA’ 
name csls6 

page 55,132 


RAM-Loadable Character Sets for the IBM PC 
Listing 6 

Richard WII ton 
July 1986 


Notes: 

This program makes available two different 256-character definition 
tables for use in enhanced alphanumeric video display modes. The 
program assumes that the proper video mode has already been 
estabIished. 

You must have at least 128K of RAM on your EGA to use this program. 

For IBM Enhanced Graphics Adapter ONLY. You should have a 350-line 
display to see the different character sizes. 


cset0 equ 0 ; character generator RAM bank #’s 

csetl equ 1 


cseg segment para public ’CODE* 


assume cs:cseg,ds:cseg 


org 100h 


initial program counter for .COM file 


; 1st 256 characters are 
Iabe10: mov bI,cset0 


mov a I , 1 

mov ah,11h 

int 10h 


9x14 ROM characters (default for 350-line display) 

; indicate bank 0 of char generator RAM 
; (A000:0000 in bit plane 2) 

; indicate 8x14 ROM characters 

; call BIOS to load character table 


; 2nd 256 characters are 8x8 ROM character set 

mov bl,csetl ; indicate bank 1 of char gen RAM 

; (A000:4000 In bit plane 2) 

mov al,2 ; indicate 8x8 ROM characters 

mov ah,11h 

int 10h 


; Enable attribute bit 3 selection of character set 


mov 

bl,(csetl sh1 2)+cset0 

; BL :« 

= value for Sequencer Character 


al ,3 

; Map 

Select register 

mov 

; "set 

block specifier" 

mov 

ah.llh 


int 

10h 

; call 

BIOS to program Sequencer 
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le bit 3 

of attribute byte 

mov 

bh ,7 


mov 

bl,12h 


mov 

al ,0 


mov 

ah,10h 


int 

10h 


lay a message 


push 

cs 


pop 

ds 


mov 

si.offset 

csmsg0 

mov 

bl .7 


mov 

cx,25 


cal 1 

show 


mov 

si.offset 

csmsgl 

mov 

bl,0Fh 


mov 

cx ,25 


cal 1 

show 


to DOS 

mov 

ax,4C00h 


int 

21h 



lette selection 
; bit mask 

; Attribute Controller: Color Plane 
; Enable register number 
; "individual palette register" 

; call BIOS to set register 


; bit 3 of attribute = 0 
; length of string 
; display string using char set 0 


; bit 3 of attribute = 1 
; display string using char set 1 


; Subroutine which displays a string using a given attribute 


show 

proc 

near 


jcxz 

show2 

showl: 

lodsb 

push 

push 

cal 1 

pop 

pop 

loop 

cx 

bx 

emi t 

bx 

cx 

showl 

show2: 

ret 


show 

endp 



Caller: DS:SI -> string 

CX = Iength of string 
BL = attribute 


; AL := next char 


; display this character 


; Subroutine which displays a single character using a given 


attribute 


proc 

near 

push 

bx 

push 

cx 

cmp 

al,20h 

j» 

emi 11 

push 

ax 

mov 

cx, 1 

mov 

bh ,0 

mov 

ah, 9 

int 

10h 

pop 

ax 

mov 

ah,0Eh 

int 

10h 

pop 

cx 

pop 

bx 

ret 


endp 



Caller: AL * character 

BL ■ attribute 

Returns: nothing, but advances 

the cursor 


jump if control character 

save char on stack 
CX :■ # of chars to write 
BH :« video display page 0 
call BIOS to write attribute and 
character at cursor 
AL :« character 

call BIOS to rewrite character in 
"teletype mode" which advances 
the cursor 
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; Strings to be displayed 


csmsg0 db 
csmsgl db 


cseg 


ends 

end 


’This Is character set 0’,0Dh,0Ah 
’This is character set 1*,0Dh.0Ah 


IabeI 0 


CSIS7.ASM 

"RAM-Loadable Character Sets for the IBM 
Richard Wilton. Inside the IBM PCs, Extra 

PC.” by 

Edition, page 197. 


title 

’extended 

character set for the HGC Plus’ 


name 

cs 1 s7 



page 

55.132 


; RAM-Loadable 

Character Sets 

for the IBM 

PC 

; Listing 7 




• Richard Wilton 



; July 1986 




; Notes: 




; This program makes available two different 256-character definition 

; tables 

for use on the 

Hercules Graphics Cord Plus. The first table 

; consists of the ROM BIOS 8 by 8 "double-dot" characters. The 

; second 

table is the reverse of the first (i.e. ( black on white rather 

; than wh 

ite on b1ack). 



; For Hercules Graphics 

Card Plus ONLY. 

cseg segment 

para public ’CODE* 


assume 

cs:cseg,ds:cseg 


org 

100h 

; 

initial program counter for .COM file 

; set configuration switch on 

HGC Plus 


1abe10: mov 

dx,3BFh 

» 

i/o port address 

mov 

a 1 ,1 

» 

activate RAM from B000:0000 

out 

dx, a 1 

• 

through B000:7FFF 

; Copy 1st 256 

character definitions into 

character generator RAM from BIOS ROM 

mov 

ax,0F000h 



mov 

ds, ax 



mov 

si,0FA6Eh 

» 

DS:SI -> start of 8x8 character 



; 

definition table in ROM 

mov 

ax,0B000h 



mov 

es. ax 



mov 

dI,4000h 

; 

ES:DI -> start of Hercules font 



» 

definition storage area 

xor 

a 1 ,a 1 

; 

AL := zero byte (used for padding) 

mov 

cx,256 

• 

CX := § of characters in table 

1abe11: push 

cx 

9 

preserve loop counter 

mov 

cx,8 

9 

CX := § of bytes in one character 



> 

definition 

rep 

movsb 

9 

copy to HGC font storage area 

mov 

cx,8 

9 

CX := § of bytes of padding 

rep 

stosb 


store zeroes 

pop 

cx 

9 

loop across all 256 characters 

loop 

1abe11 




294 BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 












IBM 


Copy 2nd 256 

character definitions into character generator RAM 

mov 

ax,0B000h 


mov 

ds, ax 


mov 

si,4000h 

; DS:SI -> start of 8x8 character 



; definition table in HGC Plus RAM 

mov 

cx,256*16 

; CX :* size of 256-character table 

abel2: lodsb 


; copy "reverse" of 1st 256 chars ... 

not 

al 


stosb 


; .. into table for 2nd 256 chars 

loop 

1abe12 


Program the 

CRT controller to disploy 25 lines of 8 by 14 characters. 

mov 

dx,3B4h 

; CRT controller register index port 

push 

cs 


pop 

ds 


mov 

s i .offset 

regs00_0D ; DS:SI -> start of table of register 



; values 

mov 

cx,0Eh 

; CX :■ loop counter 

xor 

ah, ah 

; AH :* 0 (initial CRT controller 



; register number) 

label3: mov 

al .ah 


out 

dx. a 1 

; store CRT controller index reg 

1 odsb 


; AL :■ data for CRT controller reg 

1 nc 

dx 

; DX :» 3B5h (CRT data reg port) 

out 

dx. a 1 

; store data to CRT controller reg 

dec 

dx 

; DX :« 3B4h 

i nc 

ah 

; AH := next CRT controller index # 

loop 

1abe13 


mov 

cx,3 


mov 

ah,14h 

; index value for xModeReg 

lobe 14: mov 

a 1 . ah 

; Same loop for extra CRT controller 

out 

dx.al 

; .. regs used with extended .. 



; .. character set 

1 odsb 



1 nc 

dx 


out 

dx.al 


dec 

dx 


\ nc 

ah 


loop 

label 4 


; Update BIOS 

RAM area in 

segment 40h 

mov 

ax,40h 


mov 

ds .ax 


mov 

word ptr 

ds:[4Ahl,90 ; CRT.COLS 90 

mov 

word ptr 

ds:L4ChJ,1400h ; CRT_LEN :« 90 columns * 25 rows 



; * 2 bytes/char, rounded up to next 



; higher IK 

; Oisplay a message 

« 

push 

cs 


pop 

ds 


mov 

dx,1859h 

; use BIOS scroll routine ... 

mov 

cx .0 

; .. to set attribute bytes in .. 

mov 

bh ,0 

; .. display buffer to zero 

mov 

ax,600h 


Int 

10h 


mov 

s i .offset 

csmsg0 ; 1st message 

mov 

bl ,0 

; BL (high nibble) := 0 (normal attril 



; BL (low nibble) 0 (1st 256 chars 

mov 

cx, 48 

; length of string 

cal 1 

show 

; display string using char set 0 

mov 

s 1 .offset 

csmsgl ; 2nd message 

mov 

bl,81h 

; BL (hi nibble) :» 8 (intense video) 



; BL (lo nibble) 1 (2nd 256 chars) 

mov 

cx,49 


cal 1 

show 

; display string using char set 1 


(continued) 
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; Pause, then disable RAM character generator and restore original state 
mov si.offset KeyMsg 

mov bI,0 


mov 

cx, 33 


ca 1 1 

• how 

; display "Press a key" message 

mov 

ah, 1 


int 

21 h 

; wait for a keypress 

mov 

al,14h 

; write xModeReg ... 

mov 

dx,3B4h 


out 

dx.al 

; .. to disoble extended character set 

mov 

al ,0 


inc 

dx 


out 

dx,al 


mov 

ax,7 


int 

10h 

; call BIOS, restore default video mode 

Exit to DOS 



mov 

ax,4C00h 


Int 

21h 



; Subroutine 

which displays 

a string using a given attribute 

show 

proc 

near 

; Caller: 

• 

» 

DS:SI -> string 

CX * length of string 
BL * attribute 


jcxz 

show2 



showl: 

1 odsb 


; AL := next 

char 


ca 1 1 

emi t 

; display thi 

is character 


1 oop 

showl 


show2: 

ret 




show 

endp 





Subroutine which displays a single character using a given attribute 
Bits 0-3 of the attribute byte and bits 0-7 of the character form an 
12-bit extended character code. Bits 4-7 of the attribute byte determine 
the actual attribute displayed. 


proc 

near 

push 

bx 

push 

cx 

cmp 

al,20h 

jb 

emi 11 

push 

ax 

mov 

cx, 1 

mov 

bh ,0 

mov 

ah,9 

int 

10h 

pop 

ax 

mov 

ah,0Eh 

int 

10h 

pop 

cx 

pop 

ret 

bx 

endp 

of CRT 

contro11er 


Caller: AL * character 

BL = attribute 

Returns: nothing, but advances 

the cursor 


; jump if control character 

; save char on stack 
; CX := # of chars to write 
; BH :« video display page 0 
; call BIOS to write attribute and 
; character at cursor 
; AL :«= character 

; call BIOS to rewrite character in 
; "teletype mode" which advances 
; the cursor 


register values 
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regs00_0D 

db 

6Dh, 5Ah,5Ch,0Fh 


db 

19h,06h, 19h,19h 


db 

02h,0Dh,0Ch,0Dh 


db 

00h,00h 

xModeReg 

db 

07h 

ScoreReg 

db 

0Dh 

StrikeReg 

db 

06h 

; Strings to 

be displayed 

csmsg0 db 

’These 

characters are i 

csmsgl db 

'These 

characters are i 

KeyMsg db 

0Dh,0Ah 

,'Press any key 

cseg ends 



end 

1 abe 10 



; regs 0 - 3 (8 wide) 

; regs 4-7 (14 high) 

; regs 8 - 0Bh (scans/char, 

; cursor location) 

; regs 0Ch - 0Dh (always zero) 

; "48K RamFont", 8 dot wide 
; characters 
; underscore reg 
; overstrike reg 


n the first group of 256',0Dh,0Ah 
n the second group of 256',0Dh,0Ah 
to continue . ..*,0Dh,0Ah 
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AUTO.OPS 

"Rule-based Programming," by Leonard Moskowitz, November 1986, page 217. 


;;; This is a very small OPS5 expert system which diagnoses electrical 

;;; problems in automobiles. It knows about headlights, battery, the 

;;; radio/cassette player, and a fuse box. It asks for the symptoms you note. 

If you give it just a little information, it will ask for more until it 
;;; can make a reasonable decision. If you give it a lot of information, it 
;;; decides right away. As you'd expect, the longest path is the most 
;;; ambiguous case, where the noted symptom doesn't directly implicate a 
;;; specific fault. 

;;; Run it by doing a "(make start)" and a "(run)" from top level uses LEX. 

!!! Len Moskowitz 

!!! October 1985 


Literalizations 


( I i teralize phase 

current-phase) 

(I iteralize symptom 
symptom-name 
tog) 

(I iteralize query-answer 
yes-or-no) 


Product ions 


> I I I M I 


Data Entry 




Phase 


(p give-him-the-menu 

{(start) <first-wme>j 


—> 


(make phase data-entry) 

te (crlf) [What's wrong 
te (crlf) 


(wr i 
(wr 


(crlf) 
ftabto 30) 


with the old heap now?|) 


dead-radio| (crlf) 


[tabto 30) dead-cassette| (crlf) 

'tabto 30) no-head Iights| (crlf) 

;tabto 30) one-head Iight-out| (crlf)) 

(write (crlf) iChoose your symptoms from the list and| 
jtype "end" to finish or "quit" to exit.| 
(crlf) (crlf) (tabto 30) |Symptom: |) 
(remove <first-wme>) 

(make symptom ^symptom-name (accept) *tag (genatom))) 


(p get-his-compIaints 

(phase data-entry) 

(symptom) 

-(symptom ^symptom-name quit) 

-(symptom ^symptom-name end) 

(write (crlf) (tabto 30) |Symptom: |) 

(make symptom ^symptom-name (accept) *tag (genatom))) 


(continued) 
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(p input-mispeI I Ing? 

; Check to see that his symptoms 
(phase data-entry) 
{(symptom ^symptom-name 


match our list. 


\ 


<> dead-radio 
<> dead-cassette 
<> no-head I 1ghts 
<> one-headlight-out 
<> quit 

<> end <bad-symptom> 
<unknown-symptom> \ 


i) 


(write (crlf) <bad-symptom> |is not one that I recognize. Try again: 
(remove <unknown-symptom>) 

(write (crlf) (tabto 30) jSymptom: |) 

(make symptom ^symptom-name (accept) ^tag (genatom))) 


I) 


(p remove-contradictory-symptoms 

; Can’t have both one-headlight-out and no-headlights 
(phase data-entry) 

( symptom ^symptom-name no-headlights) 

(symptom ^symptom-name one-headlight-out) <contradiction>( 


remove <contradiction>) 

write (crlf) |Can*t have it both ways! Either the headlights are out 
|or they aren’t.| (crlf) 

jl’ll ignore the one-headlight-out symptom.|) 
write (crlf) (tabto 30) |Symptom: |) 
make symptom ^symptom-name (accept) *tag (genatom))) 


I 


(p remove-duplicate-symptoms 

; If he enters the same one twice, delete one. Recognize it using the tags, 
(phase data-entry) 

S symptom ^symptom-name <name> ~tag <first-one’s-tag>) 

(symptom ^symptom-name <name> *tag <> <first-one’s-tag>) <duplicate>} 

—> 

! write (crlf) |That one was a duplicate.!) 
remove <dupIicate>)) 


(p he-wants-to-quit 
; He typed "quit" as a symptom 
(phase data-entry) 

(symptom ^symptom-name quit) 

(halt)) 


(p finished-entering-data 
; He typed "end" as a symptom 

{(phase data-entry) <what-we* re-doing>J 
(symptom ^symptom-name end) 

—> 

(write (crlf)) 

(modify <what-we* re-doing> ^current-phase diagnose)) 


Diagnose Phase 


; This is a three production data-input cluster. The first, when it 
; fires, asks a yes/no question. The second and third have 
; identical LHSes as the first except they have a condition element 
; with the answer in it too, so they fire in the right order. 

; The second has the "no" condition and the third the "yes"'* 

; condition. 

(p dead-radio-but-cassette-status-is-unknown 
(phase diagnose) 

(symptom ^symptom-name dead-radio) 

-(symptom '"symptom-name dead-cassette) 

-(symptom ^symptom-name battery-dead) 

-(symptom ^symptom-name radio-fuse-blown) 

-(symptom ^symptom-name cassette-ok) 

—> 

(write (crlf) |Is the cassette dead too? (yes/no): |) 

(make query-answer ^yes-or-no (accept))) 
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(p he-checked-the-cassette-and-it * s-ok 
(phase diagnose) 

(symptom ^symptom-name dead-radio) 
-(symptom ^symptom-name dead-cassette) 
-(symptom ^symptom-name battery-dead) 
-(symptom ^symptom-name radio-fuse-blown) 
-(symptom ^symptom-name cassette-ok) 
{(query-answer ^yes-or-no no) <answer>{ 

—> 

(remove <answer>) 

(make symptom ^symptom-name cassette-ok)) 

(p he-checked-the-cassette-and-it *s-dead 

! phase diagnose) 

symptom ^symptom-name dead-radio) 
-(symptom ^symptom-name dead-cassette) 
-(symptom ^symptom-name battery-dead) 
-(symptom A symptom-name radio-fuse-blown) 
-(symptom ^symptom-name cassette-ok) 

{(query-onswer ~yes-or-no Y es ) <answer>{ 


—> 


S remove <answer>) 

make symptom ^symptom-name dead-cassette)) 


; End of three production cluster 

; Another three production data-input cluster. 

(p dead-cassette-but-radio-status-is-unknown 
(phase diagnose) 

(symptom ^symptom-name dead-cassette) 
-(symptom ^symptom-name dead-radio) 
-(symptom ^symptom-name battery-dead) 
-(symptom ^symptom-name radio-fuse-blown) 
-(symptom ^symptom-name cassette-ok) 


—> 


(write (crlf) |Is the radio dead too? (yes/no): |) 
(make query-answer *yes-or-no (accept))) 


(p he-checked-the-radio-and-it ’s-ok 
(phase diagnose) 

(symptom ^symptom-name dead-cassette) 
-(symptom ^symptom-name dead-radio) 
-(symptom ^symptom-name battery-dead) 
-(symptom A symptom-name radio-fuse-blown) 
-(symptom ^symptom-name cassette-ok) 
{(query-answer *yes-or-no no) <answer>J 

—> 

S remove <answer>) 

make symptom A symptom-name radio-ok)) 

(p he-checked-the-radio-and-it’s-dead 
(phase diagnose) 

(symptom ^symptom-name dead-cassette) 
-(symptom ^symptom-name dead-radio) 
-(symptom ^symptom-name battery-dead) 
-(symptom ^symptom-name radio-fuse-blown) 
-(symptom ^symptom-name cassette-ok) 
{(query-answer ^yes-or-no yes) <answer>| 


—> 


S remove <answer>) 

make symptom ^symptom-name dead-radio)) 


; End of three production cluster. 

(p dead-radio-but-cassette-is-ok 

S phase diagnose) 

symptom *symptom-name dead-radio) 
(symptom ^symptom-name cassette-ok) 


—> 


(write (crlf) 


Check the antenna connection to the radio.) 

Since your tape deck still works,| (crlf) 
you are getting power to the radio.|)) 
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(p dead-cossette-but-radio-is-ok 
(phase diagnose) 

S symptom ^symptom-name dead-cassette) 
symptom ^symptom-name radio-ok) 

—> 

(write (crlf) (The radio/cassette Is getting power since the radiol 
is ok.| 

The cassette| (crlf) 
portion must be broken.| 

Remove the radio/cassette and| 
bring it In for repair.|)) 


; Another three production data-input cluster 


(p dead-cassette-and-radio 
(phase diagnose) 

(symptom ^symptom-name dead-radio) 
(symptom ^symptom-name dead-cassette) 
-(symptom ^symptom-name battery-dead) 
-(symptom ^symptom-name radio-fuse-blown) 
-(symptom '"symptom-name radio-fuse-ok) 
-(symptom ^symptom-name no-headlights) 

—> 


(write (crlf) Since both the radio and the cassette are dead,| 
check the fuse for the radio.| (crlf) 

Is it blown? (yes/no): |) 

(make query-answer ^yes-or-no (accept))) 


(p he-checked-the-radlo-fuse-and-lt-Is-bI own 
(phase diagnose) 

{ symptom ^symptom-name dead-radio) 
symptom ^symptom-name dead-cassette) 
-(symptom ^symptom-name battery-dead) 
-(symptom ^symptom-name radio-fuse-blown) 
-(symptom ^symptom-name radlo-fuse-ok) 

{(query-answer ^yes-or-no yes) <answer>} 


(remove <answer>) 

(make symptom ^symptom-name radio-fuse-blown)) 
(p he-checked-the-radlo-fuse-and-it-is-ok 
(phase diagnose) 

(symptom ^symptom-name dead-radio) 

(symptom ^symptom-name dead-cassette) 

-(symptom ^symptom-name battery-dead) 

-(symptom ^symptom-name radio-fuse-blown) 
-(symptom ^symptom-name radio-fuse-ok) 
-(symptom ^symptom-name no-headlights) 
{(query-answer ^yes-or-no no) <answer>{ 


(remove <answer>) 

(make symptom ^symptom-name radio-fuse-ok)) 


; End of three production cluster. 

(p radio-fuse-blown 

S phase diagnose) 

symptom '"symptom-name radio-fuse-blown) 

—> 

(write (crlf) |Replace the radio fuse. If it blows again when you| 
Iturn on the radio,| (crlf) 
jremove the radio for repair.|)) 

; A five production data-input cluster. If the answer to the 
; first question is no, we ask another question, hence five 
; productions instead of three. 


(p radio-fuse-ok 

S phase diagnose) 

symptom ^symptom-name radio-fuse-ok) 

-(symptom '"symptom-name battery-dead) 

-(symptom '"symptom-name no-headlights) 

-(symptom ^symptom-name one-headlight-out) 

—> 

(write (crlf) |Hmm. Both the radio and cassette are dead,| 
the radio fuse is ok.| (crlf) 

and we’re still not getting power. Turn on your| 
headlights.| (crlf) |Are they both on? (yes/no): |) 
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(make query-answer ^yes-or-no (accept))) 


(write (crlf) 


(p no-radio-but-both-headIights-are-on 
(phase diagnose) 

(symptom ^symptom-name radio-fuse-ok) 

-(symptom ^symptom-name battery-dead) 

-(symptom ^symptom-name no-headlights) 

{(query-answer ^yes-or-no yes) <answer>{ 

—> 

(remove <answer>) 

(make symptom ^symptom-name head Iights-ok) 

Very curious. It appears that the battery is ok,| 
but still no radio.| (crlf) 

It could be a broken wire somewhere. Get out a| 
voltmeter and a schematic and| (crlf) 
trace back from the radio. If there's voltage at the| 
radio, then remove the| (crlf) |radio for repair.| 
Otherwise, I’m stumped. Sorry!j)) 

(p no-radio-and-both-headI 1ghts-are-not-on 
(phase diagnose) 

(symptom ^symptom-name radio-fuse-ok) 

-(symptom ^symptom-name battery-dead) 

-(symptom ^symptom-name no-headlights) 

{(query-answer ^yes-or-no no) <answer>} 

—> 

(remove <answer>) 

(make symptom ^symptom-name head Iights-not-ok) 

(write (crlf) |Is one headlight on? (yes/no): |) 

(make query-answer ^yes-or-no (accept))) 

(p we-found-that-one-headIight-is-out 

S phase diagnose) 

(symptom ^symptom-name head Iights-not-ok) cheadIight-probIem>} 
-(symptom ^symptom-name one-headlight-out) 

-(symptom ^symptom-name no-headlights) 

{(query-answer ^yes-or-no yes) canswer>} 


—> 


(p we- 


—> 


S remove <answer>) 
remove <headIight-probIem>) 

(make symptom ^symptom-name one-headlight-out)) 

found-that-both-headIights-are-out 
(phase diagnose) 

{(symptom ^symptom-name head Iights-not-ok ) cheadIight-probIem>} 
-(symptom ^symptom-name one-headlight-out) 

-(symptom ^symptom-name no-headlights) 

{(query-answer ^yes-or-no no) canswer>} 

(remove <answer>) 

(remove cheadIight-probIem>) 

(make symptom A symptom-name no-headlights) 

(write (crlf) |Both headlights are out.|)) 


End of five-production cluster 


(p no-radio-but-one-headIight-is-on 
(phase diagnose) 

(symptom ^symptom-name radio-fuse-ok^ 
-(symptom ^symptom-name battery-dead) 
-(symptom ^symptom-name no-headlights) 
(symptom ^symptom-name one-headlight-out) 


—> 


(make symptom 
(write (crIf) 


A symptom-name battery-not-dead) 

Very curious. It appears that the battery is ok, 
but still no radio.| (crIf) 

It could be a broken wire somewhere. Get out a| 
voltmeter and a schematic and| (crlf) 
trace back from the radio. If there’s voltage at 
radio, then remove the| (crlf) |radio for repair. 
Otherwise, I’m stumped. Sorry!j)) 


the | 


(p battery-not-dead-because-radio-or-cassette-or-headlights-ok 
(phase diagnose) 

(symptom ^symptom-name « radio-ok cassette-ok head Iights-ok 
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one-headlight-out ») 
-(symptom ^symptom-nome battery-not-dead) 

—> 

(make symptom ^symptom-name battery-not-dead)) 


(p one-headi Ight-needs-to-be-repIaced 

S phase diagnose) 

symptom ^symptom-name one-headlight-out) 

—> 

(write (crlf) |Replace the dead headlight with one of the same type.|)) 
; Another three production data-lnput cluster. 


(p both-headlights-out-and-no-indication-that-other-things-work 

S phase diagnose) 

symptom ^symptom-name no-headlights) 

-(symptom ^symptom-name battery-not-dead) 

-(symptom ^symptom-name dead-cassette) 

-(symptom ^symptom-name dead-radio) 

—> 

(write (crlf) |Does the radio or cassette (either) work? (yes/no): |) 
(make query-answer '"yes-or-no (accept))) 

(p both-headlights-out-and-we-found-something-eIse-works 

S phase diagnose) 

symptom ^symptom-name no-headlights) 

-(symptom ^symptom-name battery-not-dead) 

-(symptom ^symptom-name dead-cassette) 

-(symptom ^symptom-name dead-radio) 

{(query-answer *yes-or-no yes) <answer>{ 

—> 

(remove <answer>) 

(make symptom ^symptom-name battery-not-dead)) 


(p both-headlights-out-and-we-found-nothing-eIse-works 
(phase diagnose) 

(symptom ^symptom-name no-headlights) 

-(symptom ^symptom-name battery-not-dead) 

-(symptom ^symptom-name dead-cassette) 

-(symptom ^symptom-name dead-radio) 

{(query-answer ^yes-or-no no) <answer>} 

—> 

(remove <answer>) 

(make symptom ^symptom-name dead-radio) 

(make symptom ^symptom-name dead-cassette) 

(make symptom ^symptom-name dead-battery) 

(write (crlf) |Seems like the battery might be dead.!)) 


; End of three-production cluster. 

(p both-headlights-out-and-something-eIse-is-dead 
(phase diagnose) 

(symptom ^symptom-name no-headlights) 

(symptom ^symptom-name dead-radio) 

(symptom ^symptom-name dead-cassette) 

-(symptom ^symptom-name battery-not-dead) 

-(symptom ^symptom-name dead-battery) 

—> 

(make symptom ^symptom-name dead-battery) 

(write (crlf) |Seems like the battery might be dead.|)) 
(p both-headlights-out-and-other-things-work 
(phase diagnose) 

(symptom ^symptom-name no-headlights) 

(symptom ^symptom-name battery-not-dead) 


(write (crIf) 


The battery isn't dead but the headlights are out.| 
Check the headlight fuse.| (crlf) 

If it’s good, it’s rather unlikely, but maybe both| 
headlights are broken.! (crlf) 

Try replacing one headlight.!)) 


(p query-answer-must-be-yes-or-no 

; Check that the answer was either yes or no. If not, ask again. 
; This does checking for all the yes/no questions. 

{(query-answer { <> yes <> no { ) <answer>( 
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(remove <answer>) 

(write (crlf) |Please answer yes or no (yes/no): |) 
(make query-answer ^yes-or-no (accept))) 


Clean Up and Start Over 


(p catch-all-production 

; If we are diagnosing and nothing else fires, this will. Starts the clean-up. 
{(phase diagnose) <where-we-are>} 

—> 

(write (crlf) |Done. Starting over.|) 

(modify <where-we-are> ^current-phase clean-up)) 

(p empty-the-working-memory 

; Remove everything from working memory except "phase" 

(phase ^current-phase clean-up) 

{( <> phase ) <any>{ 

—> 

(remove <any>)) 

(p working-memory-has-nothing-eIse-but-"phase"-so-make-a-new-start 
; Remove "phase" and make a new "start" 

{(phase ^current-phase clean-up) <a-flag>{ 

-(<> phase) 

—> 

(remove <a-fIag>) 

(write (crlM) 

(make start)) 


DESUPSYS.LST 

"Handling Conflicts in Data," by Clara Y. Cuadrado and 
John L. Cuadrado, November 1986, page 193. 


Listing 1 

% The various possible teams are: 

tearns([team(char Iie.bob).team(char Iie.alan), 
team(char lie,dan),team(bob,a I an), 
tearn(bob,dan),team(a I an,dan)]). 

% Mike’s opinions are: 

mike(credibilityfassumption,3),[opinion],[]). 
mike(credibility(bob ,4) ,[op in ion],[]). 
mikefcredibiIityfcharlie,3),[op ini on!,[]). 
mike(credibiIity(dan , 2 ), [opinion],[ 1). 
mike(credibility(alan,1),[opinion],[]). 

% Jack’s opinions are: 

jack(technicaIncompetence(assumption,3),[opinion],[]). 
jack(technicaIncompetence(dan,5),[opinion],N). 
jack(technicaIncompetence(a I an,4),[opinion],[]). 
jack(techn ica I ..competence (bob, 3) ,[opinion],[]). 
jack(technicaIncompetence(char Iie,2),[op ini on],[]). 

% Bob’s opinions are: 

bobfcan_worknWithfno.bob,aI an),[opinion],[]). 
bob(can_worknWith(yes,bob,char Iie),[op ini on],[]). 
bobfcannWork_withfyes,bob,dan),[op ini on],[]). 
bob(cannWorknWith(no ,a I an , char lie),Fop ini on],[])• 
bob(cannWorknWith(yes,charlie,dan),[opinion],[]). 

% Alan’s opinions are: 

a Ian(can_worknWithfyes ,a I an,bob) , [opinion] , []) . 
a Ianfcan.worknWithfyes,alan,char lie),[opinion],M). 
a Ian(can_work_with(yes,bob,char Iie),[op ini on],[])• 


( continued) 
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X Charlie's opinions are: 

char Iiefcan_work_withfyes,char Iie,a I an ) ,[opinionl, 
chariie(can_work_with(yes.a I an,char lie),[op in ionj, 
char Iie(can_work_withfyes, charIie,bob),[opinion],[ 
char Iie(can_work_with(yes,bob,char Iie),[opinionJ,[ 

% Dan's opinions are: 

dan(can_work_wi thfyes,dan,a I an), [opin Ion], [ 1). 
dan(can_work_with(yes,dan,bob),[opinion],[J;. 
danfcan_work_withfyes,dan,char Iie),[op ini on],[]). 
dan(can_work_with(yes,alan,Charlie),[op ini on],[]). 
dan(can_work_with(no,a I on,bob),[opinion],[]). 

/* The main predicate of the system is "decide." 
This is what a top-level manager, like Penelope in 
our story, would use to produce rankings for each 
of the possible teams for a given project. 

*/ 

decide 



evaIuate(mike,[bob,char Iie,a I an,dan]), 

% generate Mike's view 
rank_tearns(Rankings), 
eligible(Rank!ngs,EIigible), 

% determine eligible teams 
sortem(EIigib Ie,Sorted), 
c I s, 

report_ranks(Sorted), 
n I . 

% The "eligible" predicate is a filter that applies a 
% threshold criterion to each of the possible teams. 

% It discards those teams whose compatibility is below 
% the given threshold (specified as 3 in this case), 
el iglblefn, []). 

elIgible([team(P1,P2,R1,R2)|Teams].[teom(P1.P2.R1,R2)|Es]) 
R1 >- 3. 

% teams with Compatibility 3 or higher are OK 
el iaible(Teams,Es). 
eligible([_|Teams],Es) 

% teams with low Compatibility we discard 
e I igibIe(Teams,Es). 


% the "rank_teams" predicate produces rankings for each 

% of the teams based on both compatibility (according 

% to Mike) and competence (according to Jack). 

rank_teams(Rankings) 

els, writef'PI ease wait while*) 

wr ite(’eIigibIe teams are ranked.'), 
teams(Teams), 

% fetch the possible teams from the database 
rankem(Teams,Rankings), 

r ankemf[],[]). 

rankem([team(P1,P2)|Teams],[team(P1,P2,R1,R2)|Rankings]) 
assess_compatibiIity(mike,P1,P2,R1), 
assess_competence(jack,P1,P2,R2), 
rankem(Teams.Rankings). 

report_ranksf[]). 

report_ranks([team(P1,P2,R1,R2)|Teams]) 
report_ranking(P1,P2,R1,R2), 
report_ranks(Teams). 

report_rank1ng(P1,P2,R1,R2) 

nl,write('for the team of '),write(P1), 
write(' and '),write(P2),nI, 
writef'compatibiI 1ty (according to '), 
wrlte('Mike) —> '),write(R1), 
write(’ competence (according to *), 
wr ite(* Jack) —> *),write(R2),nI. 

assess_competence(View,P1,P2,R) 

VI «.. [jack,technical_competence(P1,R1),_,_], 
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vi. 

V2 = .. [jack,technical_competence(P2,R2), 

V2, 

R is R1 + R2. 

% We do not assume that the compatibility relation 
% "can_work_with M is symmetric. That is, it may be 
% possible to have "can_work_with(yes,bob,char Iie)" 

% and yet also have "can_work_with(no,char Iie,bob)" 

% Therefore, in assessing compatibility we look at 
% the relation going both ways and then take an average. 
assess_compatibiIity(View,P1,P2,R) 
assessment(View,PI,P2,R12), 
assessment(View,P2,PI,R21), 

R is (R12+R21)//2. 

assessment(View,PI,P2,ResuIt) 

rankfView,can_work_with(yes,P1,P2),Yes), 
rank(View,can_work_with(no,P1,P2),No), 

Result is Yes - No. 

rank(View,Predicate,Rank) 

V = .. [View.Predicate,Sby,_], 

V, 

ana Iyze(View,Sby,Rank). 
rank(_,_,0). 

analyze(_,[],0). 

ana Iyze(View,[Sby|$bys],I) 

V «.. [View,credibiIity(Sby,W), 

V, 

ana Iyze(View,Sbys,II), 

I is II + W. 


/* Typical output for the "decide" predicate, 
when run with the database of workers’ opinions 
about their mutual compatibility and their managers’ 
evaluations, is as follows: 
for the team of bob and don 
compatibility (according to Mike) —> 3 
competence (according to Jack) —> 8 

for the team of Charlie and dan 
compatibility (according to Mike) —> 3 
competence (according to Jack) —> 7 

for the team of Charlie and bob 
compatibility (according to Mike) —> 5 
competence (according to Jack) —> 5 
*/ 

/* Predicates to propagate "new" information 
*/ 

% The "evaluate" predicate cycles through a list 
% of Persons and ascertains their opinion on the 
X compatibility of the various workers. It installs 
% these views in the View frame. 

evaIuate(View,Persons) :-cls, write(’PIease wait for 
propagation of information.'), 1nv(View,Per sons,Per sons). 

1nv(_,[] 

inv(V,[P|Ps].Persons) 

i nvl(V,P,Persons), 

Inv(V,Ps.Persons). 


I nv 
inv 


1(V._.[]). 

1(V,P»[P|Ps]) 
Invl(V.P.Ps). 


inv1(V.P.[PP|P«]) 

explore(V,P,PP,[bob.char Iie.olon,donJ), 
Invl(V.P.Ps). 


X The "explore" predicate determines who con work 


(coittmurd) 
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X with whom and propagates this information both 
% forward and backward. That is, for a given pair 
X of individuals it determines whether they can 
X work together according to the various Views and 
% for each of these views it manages both the 
X Supported_by and the Supports slots for the 
X "can_work_with" relation, 
explore(View,PI,P2,Views) 

gather_evidence(View,can_work_wlth(yes,P1,P2),Views), 
gather_evidence(View,can_work_with(no,P1,P2),Views), 
assessment(View,PI,P2,ResuIt). 

gather_evidence(Checker.Predicate,Views) 
checkem(Checker.Predicate,Views). 

checkemf []). 

checkem(Checker.Predicate,[V|Vs]) 
check(Checker,V,Predicate), 
checkem(Checker,PredI cate,Vs). 

check(Checker,View.Pred) 

V =.. [View.Pred.Sby.S], 
retract(V), 

update_view(View.Pred,Sby,Checker,$), 

% adjust what View supports 
update_checker(Checker,View.Pred). 

X adjust what Checker is supported_by 
check(_,_,_). 

% this View does not support this Pred, no harm done. 

X Update the Support set for this Pred in this View 
update_vIew(View.Pred,Sby,Checker,S) 
member(Checker,S), 

X if already in Support set don't add it again 

V ».. [View.Pred.Sby.S]. 
assert(V). 

update_v1ew(View.Pred,Sby,Checker,S) 

V ■ .. [View.Pred,Sby,[Checker|S]], 
assert(V). 

% Update the Supported_by set for this Pred in this View 
update_checker(Checker.View,Pred) 

C -.. [Checker,Pred.Sby.S], 
retract(C), 

% Is Pred already supported_by other views? 

(member(View.Sby), 

% is this View already recorded? 
assert(C) 

% yes, don't include again 

New_C [Checker,Pred,[View|Sby],S], 
assert(New_C) 

update_checker(Checker.View,Pred) 

% Pred not supported by any 

C [Checker,Pred,[View],[]], 

% other views so far 

assert(C). 

% The "assume" predicate is used in "what If" 

% processing. That is, the user can add 
% assumptions at any level and they will be 
% propagated through the system. For example, 

X Mike might find there is no information on 
% the compatibility of Alan and Dan. He can 
% then assume that is true: 

% assume(mike,can_work_with(yes,a I an,dan)) 

% and run the system to see what impact this 
% has on the team rankings. 
assume(View,Pred) 

update_checker(View,assumption,Pred). 

/* Predicates to withdraw information 
*/ 

% The "remove" predicate retracts Pred from the 
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X given View. It also adjusts the Supported_by 
% set and the Supports set. It is used primarily 
% in "what if" processing. For example, Mike might 
% decide to discard Charlie’s opinion on the 
X compatiIbiIity of Bob and Dan. He can do this 
% by issuing the command: 

% remove(char I 1e,can_work_wlth(yes,bob,dan)) 

X and then run the system to see the impact on the 
X team rankings. 
remove(View,Pred) 

V [View,Pred,Sby,S], 
retract(V), 

adjust_Sby(View.Pred,Sby), 
adjust_S(View.Pred,S). 

adjust_Sby(_,_,[]). 

adjust_$by(View,Pred,[assumption|Sbys]) 

X if It was an assumption 

ad just_Sby(View.Pred,Sbys). 

% there nothing to go back to 
adjust_Sby(View.Pred,[Sby|Sbys]) 

V ».. [Sby,Pred,SSby,S], 
retract(V), 

efface(View,S,New_S), 

W [Sby,Pred,SSby,New_S], 
assert (W), 

adjust_Sby(VIew.Pred,Sbys). 

adjust_S(_,_,[]). 

ad just_S(View.Pred,[S|Ss]) 

V . [S.Pred.Sby.SS], 
retract(V), 

efface(View.Sby,New_Sby), 
check_empty_Sby(S,Pred,New_Sby,SS), 
adjust_S(View.Pred,Ss). 

X If Pred no longer has any Support under this 
X view then we had better adjust all other things 
% that depend on it 
check_empty_Sby(View.Pred,[],S) 
ad just_S(View.Pred,S). 
check_empty_Sby(Vlew.Pred,Sby,S) 

% we still have a non-empty Sby 

V [View.Pred,Sby,S], 

X so no problem upstream 

assert(V). 

/* Utilities 
*/ 

X pretty print a Predicate according to a certain View 
ppr(View,Predicate/Arity) 

functor(F.Predicate,Arity), 

V =.. [View,F,Sby,S], 

V. 

nI, write(F), 

n I ,tab(5),write(’Supported_by: *),write(Sby), 
nl,tab(5),write(’Supports: '),write(S),nl, 
fai I . 
ppr(_,_). 


X remove the first occurrence of an element from a list 

].[]):- !• 

# , l L J> L ) «• 

efface(A,[BjLJ,[B|M]) efface(A,L,M). 


efface 

efface 


memberfX,[Xl 1). 

member(X,|YJ) member(X.Y). 


% do quicksort 

sortem(LIst.Result) qsort(List.Result,[]). 
qsort([H|T],S,X) 

spI 11(H,T,A,B), 
qsort(A,S,[H|Y]), 
qsort(B,Y,X). 


(continued) 
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qsort([],X,X). 

. yt i4‘ 

spllt(H,[A|X],[A|Y],Z) 
order(A,H), 
split(H,X,Y,Z). 

spit t(H,[A|X],Y,[A|Z]) 
splIt(H,X,Y,Z). 

•piitun. ii.m. 

order(team(_,_,_,A),team(_,_,_,B)) 

A > B. 

/* End of program. */ 


HOUSE.BAS 

"Bit-Mapped Classifier," by Peter W. Frey, November 1986, page 161. 


REM 

*** 

REM 

*** 

REM 

C 

REM 


REM 


REM 

CR 

REM 


REM 


REM 


REM 

Q$ 

REM 

NQ 

REM 

H$ 

REM 

FG 

REM 

FP 

REM 

FT 

REM 

CT 

REM 

MK 

REM 

CV 

REM 

NC 

REM 

NE 

REM 

*** 

DEFINT 

B-Z 


HOUSE ARCHITECTURE WITH CLASSIFIERS *** 

LIST OF VARIABLES *** 

Array of Integers representing classifiers 
first index « classifier number 

second Index = 16 bit field within each classifier 
Array of integers indicating relevant bits in classifier 
first index » type A or B or C 
second index = classifier number 
third index ■ 16 bit field within each classifier 
Array of diagnostic questions (string variables) 

Number of questions (integer variable) 

Array of house architectual types (string variables) 
Boolean array for presence of graphic info for each feature 
Integer array with bits set for features which are present 
Integer array with bits set for features tested 
Integer array of threshold value for each classifier 
Integer array of words used as bit masks 
Integer array of values for each classifier 
Number of classifiers 

Number of houses for which all features are known 
INITIALIZATION *** 


WINDOW CLOSE 1 

DIM C(60,10), CR(3,60,10), CT(60), CV(60) 
DIM FP(10), FT(10), MK(16), FG(160) 

DIM Q$(160),H$(60) 

FG(23)«1:FG(24)=1:FG(25)-1 
T$(1)-"A":T$(2)-"B":T$(3)-"C" 

FOR J = 1 TO 10 

FP(J) - 0:FT(J)=0 
NEXT J 

FOR I = 1 TO 59 
CV(I) - 0 
NEXT I 

NE»0:BS»60:CV(BS)=-500 
B = MOUSE(0) 


REM *** READ 16 BIT-MASKS *** 

FOR J = 1 TO 16:READ MK(J):NEXT J 

REM *** DISPLAY INFORMATION *** 

WINDOW 1,,(40,70)-(472,280),2 

PRINT:PRINT TABf12);"EXPERT SYSTEM FOR HOUSE ARCHITECTURE" 

PRINT:PRINT TAB(3); "This program is designed to help you identify the architectural" 
PRINT "style of family homes. The computer will ask you questions about" 

PRINT "specific attributes of the house you are examining. Respond to these" 

PRINT "questions by clicking the mouse on the appropriate answer. If you" 

PRINT "are not sure about the proper response, choose the alternative which" 

PRINT "is most nearly correct." 

REM *** READ LIST OF QUESTIONS *** 

LI: READ N:IF N = 999 THEN L2 

READ Q$(N):NQ«N:GOTO LI 
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REM *** READ CLASSIFIERS k RELEVANCE MASKS *** 

L2: READ N:IF N = 999 THEN L3 

READ H$(N), CT(N):NC » N 
FOR H = 1 TO 3 

Cl: READ N:IF N-999 THEN C2 

NA * ABS(N) 

J = INT((NA-1)/16) + 1 
K = ((NA-1) MOD 16) + 1 
CR(H,NC,J) = CR(H,NC,J) OR MK(K) 

IF N > 0 THEN C(NC,J) » C(NC.J) OR MK(K) 

GOTO Cl 

C2: NEXT H 

GOTO L2 

L3: PRINTiPRINT TAB(18);"CLICK THE MOUSE TO BEGIN" 

DZ: IF MOUSE(0) - 0 THEN DZ 

WINDOW CLOSE 1 

REM *** CREATE MENUS *** 

MENU 6,0,1,"Debug" 

MENU 6,1,1,"Message" 

MENU 6,2.1,"Classifiers" 

MENU 7,0,1."Crosstabs" 

MENU 7,1.1,"House Types" 

MENU 7,2,1,"Features" 

ON MENU GOSUB PME 
MENU ON 

REM *** DETERMINE DATE OF CONSTRUCTION *** 

Q$ = "When was the house built 7" 

WINDOW 1,Q$,(120,60)-(390,310),1 

BUTTON 1.1,"before 1820",(80,20)-(180.40) 

BUTTON 2,1,"1820 to 1880",(80,65)-(180,85) 

BUTTON 3,1,"1880 to 1940",(80.110)-(180,130) 

BUTTON 4,1,"ofter 1940",(80,155)-(l80,175) 

BUTTON 5,1,"unknown",(80,200)-(180,220) 

GOSUB QUERY 
IF B - 5 THEN L4 
J-'kK-BiFPtJ) = FP(J) OR MK(K) 

FOR K-1 TO 16:FT(J) - FT(J) OR MK(K):NEXT K 
WINDOW CLOSE 1 

FOR K - 1 TO 4:GOSUB ADJ:NEXT K 

REM *** GET SLOPE OF THE ROOF *** 

L4: Q$ * "What is the slope of the roof 7" 

WINDOW 1,Q$,(90,60)-(420,290) 

BUTTON 1,1,"fI at",(60,20)-(330,45),2 
BUTTON 2.1."less than 30 degrees",(60,60)-(330,85),2 
BUTTON 3,1,”30 to 45 degrees",(60,100)-(330,125),2 
BUTTON 4,1,"more than 45 degrees",(60,140)-(330,165).2 
BUTTON 5,1."combination of the above",(60,180)-(330,200).2 
GOSUB QUERY 

J-1:K-B+4:FP(J) - FP(J) OR MK(K) 

WINDOW CLOSE 1 

FOR K - 5 TO 9:GOSUB ADJ:NEXT K 

REM *** COMPOSITION OF EXTERIOR WALLS *** 

Q$ ■ "The exterior walls ore mode of ?" 

WINDOW 1,Q$,(90,60)-(420.300) 

BUTTON 1,1,"wood",(60,20)-(260,45).2 

BUTTON 2,1,"stone",(60,55)-(260,80),2 

BUTTON 3,1,"brIck",(60,90)-(260,115),2 

BUTTON 4,1,"stucco or adobe",(60.125)-(260,150).2 

BUTTON 5.1."combination of the above",(60,160)-(260,185),2 

BUTTON 6,1,"other",(60,195)-(260,220),2 

GOSUB QUERY 

J-1:K«B+9:FP(J) - FP(J) OR MK(K) 

WINDOW CLOSE 1 

FOR K-10 TO 15:G0SUB ADJ:NEXT K 

REM *** ROOF-WALL JUNCTION *** 

Q$ » "Junction between roof ond exterior wall 7" 

WINDOW 1,Q$,(40,55)-(465,315) , 

BUTTON 1,1,"little or no overhang (no eaves)".(50.30)-(380.50).2 

BUTTON 2.1,"exterior wall extends above roof (parapet)",(50,60)-(380,80),2 

8UTT0N 3,1,"slight overhang with exposed rafters”,(50,90)-(380,110),2 
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BUTTON 4,1,"slight overhang with boxed eaves".(50,120)-(380,140),2 
BUTTON 5,1,"wide overhang with exposed rafters",(50,150)-(380,170),2 
BUTTON 6,1,"wide overhang with boxed eaves".(50,180)-(380,200),2 
BUTTON 7,1,"other".(50,210)-(380,230),2 
GOSUB QUERY:BIT - B + 15 
J - INT((BIT-1)/16) + 1 
K - ((BIT-1) MOD 16) + 1 
FP( J) - FP(J) OR MK(K) 

J-2:F0R K -1 TO 6:FT(J) - FT(J) OR MK(K):NEXT K 
WINDOW CLOSE 1 
J-1:K-16:G0SUB ADJ 
J-2:F0R K«1 TO 6:GOSUB ADJ:NEXT K 
GOSUB TAP 

REM *** MAIN LOOP *** 

REM *** GET NEXT QUESTION *** 

L9: IF CV(M1) > CT(M1) THEN L40 

IF CV(BS)+470 > CV(M1) THEN M1*BS:GOTO L40 
H » 0 

L10: H = H + 1:IF H > 3 THEN L20 

J - 1 

LI1: J - J + 1sIF J > 10 THEN L10 

Q«CR(H,M1,J):IF Q-0 THEN L11 
K - 0 

L12: K = K + 1sIF K > 16 THEN L11 

T » Q AND MK(K) AND NOT FT(J) 

IF T » 0 THEN L12 
N - 16*(J-1) + K 
Q$ - Q$(N) 

GOSUB YN 

FT(J) - FT(J) OR MK(K) 

IF B-1 THEN FP(J) = FP(J) OR MK(K) 

GOSUB ADJ 
GOSUB TAP 
GOTO L9 

L20: CV(M1) = CV(M1)-500 

IF CV(M1) > CV(BS) THEN BS=M1 

NE = NE + 1:IF NE>5 THEN L30 

WINDOW 3,"BEST SO FAR",(320,170)-(500,220) 

MOVETO 20,20:PRINT H$(BS);SPC(2);CV(BS)+500; 

GOSUB TAP 
GOTO L9 

L30: IF CV(R1)+500 > 15 THEN M1-R1:GOTO L40 

WINDOW CLOSE 2:WINDOW CLOSE 3 
WINDOW 1,,(80,120)-(430,220),2 

MOVETO 30,50:PRINT "This house does not fit any of my categories" 

GOTO TRAP 

L40: WINDOW CLOSE 2:WINDOW CLOSE 3 

WINDOW 1,,(80,120)-(430,220),2 

MOVETO 30,50:PRINT "The architectural style is M ;H$(M1); 

TRAP: GOTO TRAP 

REM *** ADJUST CLASSIFIER VALUES *** 

ADJ: FOR I * 1 TO NC 

IF CV(I) = -99 THEN A3 
TR = NOT(C(I,J) XOR FP(J)) 

H = 1:RB = CR(H,I,J) AND MK(K) 

IF RB = 0 THEN A1 
TB = TR AND RB 

IF TB « 0 THEN CV(I)=-99 ELSE CV(I)*CV(I)+5 
GOTO A3 

A1: H - 2:RB = CR(H,I,J) AND MK(K) 

IF RB - 0 THEN A2 
TB = TR AND RB 

IF TB = 0 THEN CV(I)*CV(I)-5 ELSE CV(I)*CV(I)+5 
GOTO A3 

A2: H = 3:RB = CR(H,I,J) AND MK(K) 

IF RB = 0 THEN A3 
TB = TR AND RB 

IF TB » 0 THEN CV(I)=CV(I)-1 ELSE CV(I)=CV(I)+5 
A3: NEXT I 

RETURN 

REM *** SUBROUTINE TO CHECK DESKTOP *** 
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QUERY: D = DIALOG(0): IF D <> 1 THEN QUERY 

8 = DIAL0G(1):BUTTON B.2 

RETURN 

REM *** SUB TO ASK YES-NO QUESTION *** 

YN: IF FG(N) = 0 THEN Y1 

WINDOW 4,,(70,135)-(260,235),3 

TQ - N-22:ON TQ GOSUB G1,G2,G3,G4,G5 

Y1: WINDOW 1,"Does the house hove",(30,50)-(480,130),1 

Y2: NT«0:NL = LEN(Q$):LB = 200 - NL*3 

MOVETO LB.20:PRINT Q$;" ?“; 

BUTTON 1,1,"Yes".(150,40)-(190,60) 

BUTTON 2,1,"No",(230,40)-(270,60) 

Y3:D = DIALOG(0):NT = NT + 1:IF NT > 600 THEN Y2 
IF D <> 1 THEN Y3 
B - DIALOG(1):BUTTON B.2 
WINDOW CLOSE 1:WINDOW CLOSE 4 
RETURN 

REM *** PROCESS MENU SELECTION *** 

PME: M - MENU(0):IF M = 7 THEN CRT 

IF M <> 6 THEN RETURN 
MENU 6,S,1:S - MENU(1) 

MENU 6,S,2:MENU 

ON S GOSUB MESS, CLAS 

RETURN 

REM *** DISPLAY MESSAGE *** 

MESS: WINDOW CLOSE 2 

WINDOW 4."".(20.35)-(490,305),2 
PRINT:PRINT TAB(22);"CURRENT MESSAGE" 

PRINT TAB(13);"BITS TESTED";SPC(14);"BITS SET" 

FOR J2 = 1 TO 10:PRINT TAB(10); 

FOR K2 = 1 TO 16:T = FT(J2) AND MK(K2) 

IF T <> 0 THEN PRINT "1"; ELSE PRINT "0"; 

NEXT K2:PRINT SPC(6); 

FOR K2 = 1 TO 16:T - FP(J2) AND MK(K2) 

IF T <> 0 THEN PRINT "1"; ELSE PRINT "0"; 

NEXT K2:PRINT 
NEXT J2 

PRINT:PRINT TA8(20);"HIT ANY KEY TO CONTINUE": 

MZ: R$=INKEY$:IF R$ = "" THEN MZ 

WINDOW CLOSE 4 

RETURN 


CLAS: WINDOW CLOSE 2 

WINDOW 4, “" , (10,35)-(500,320),2 

PRINT:PRINT TAB(20);"LEADING ACTIVE CANDIDATE" 

PRINT TAB(22);H$(M1) 

PRINT TAB(7);"CIossifier";SPC(14);"Mask A";SPC(13);"Mosks B & C" 
FOR J3 = 1 TO 10 
PRINT TAB(3); 

FOR K3 - 1 TO 16 

T - C(M1,J3) AND MK(K3) 

IF T <> 0 THEN PRINT "1"; ELSE PRINT "0"; 

NEXT K3:PRINT SPC(4); „ 

FOR K3 - 1 TO 16 

T - CR(1,M1,J3) AND MK(K3) 

IF T <> 0 THEN PRINT "1"; ELSE PRINT "0"; 

NEXT K3:PRINT SPC(4); 

FOR K3 - 1 TO 16 

T - (CR(2,M1,U3) OR CR(3,M1,J3)) AND MK(K3) 

IF T <> 0 THEN PRINT "1"; ELSE PRINT "0"; 

NEXT K3:PRINT 
NEXT J3 

PRINT:PRINT TAB(21);"HIT ANY KEY TO CONTINUE": 

CZ: R$«INKEY$:IF R$ - "" THEN CZ 

WINDOW CLOSE 4 

RETURN 

TAP: M1-60:M2-60:M3-60:CV(M1) - -500 

FOR I - 1 TO NC 

IF CV(I) > CVfMI) THEN M3-M2:M2-M1:M1-I:GOTO T1 
IF CV(I) > CV(M2) THEN M3-M2:M2-I:GOTO T1 
IF CV(I) > CV(M3) THEN M3-I 
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T1: NEXT I 

WINDOW 2."ACTIVE CANDIDATES",(20,260)-(480,330),1 
MOVETO 40,15 

PRINT CV(M1):V;CT(M1);SPC(3);H$(M1); 

MOVETO 40,35 

PRINT CV(M2);;CT(M2);SPC(3);H$(M2); 

MOVETO 40,55 

PRINT CV(M3);;CT(M3);SPC(3);H$(M3); 

RETURN 

REM *** PROCESS MENU INTERRUPT *** 

CRT: WINDOW CLOSE 2 

MENU:NX-0:IF MENU(1) - 2 THEN PM5 

IF MENU(1) <> 1 THEN RETURN 

PM1: WINDOW 3,"WHICH HOUSE TYPE ?",,1 

MXI-12:IF MXI>NC-NX THEN MXI-NC-NX 

FOR I1-1 TO MXI 

BUTTON II,1,H$(II+NX),(40,20*II-5)-(240,20*II+10),2 
NEXT II:IF NC-NXC13 THEN PM2 
MXI-24:IF MXI>NC-NX THEN MXI-NC-NX 
FOR II - 13 TO MXI 

BUTTON II,1.H$(II+NX).(260.20*I1-245)-(470.20*11-230),2 
NEXT II 

PM2: IF NX+24<NC THEN BUTTON 25,1."MORE",(80.260)-(200,280),3 

BUTTON 26,1,"EXIT",(300,260)-(420.280),3 

PM3: IF DIAIOG(0) <> 1 THEN PM3 

KCH=DIALOG(1):BUTTON KCH, 2 

IF KCH-25 THEN NX-NX+24:G0T0 PM1 

IF KCH*26 THEN PM9 

HC-KCH+NX:R$-"RELEVANT FEATURES FOR "+H$(HC) 

WINDOW 3,R$.,1 
NF-0 

FOR HH - 1 TO 3 

FOR JJ - 1 TO 10 

FOR KK = 1 TO 16 

TCB = CR(HH.HC.JJ) AND MK(KK) 

IF TCB = 0 THEN PM4 

NF-NF+1:NN-(JJ-1)*16 + KK 

PRINT SPC(1);T$(HH);SPC(3);Q$(NN) 

IF NF - 16 THEN GOSUB PAU 

PM4: NEXT KK 
NEXT JJ 
NEXT HH 

BUTTON 1,1,"EXIT",(430.270)-(490.290).3 
PM4A: IF DIALOG(0) <> 1 THEN PM4A 

KCH-DIALOG( 1) : IF KCHol THEN PM4A 
BUTTON 1,2:GOTO PM9 

PM5: WINDOW 3,"WHICH FEATURE ?",,1 

MXI-12:IF MXI>NQ-NX THEN MXI-NQ-NX 
FOR 11-1 TO MXI 

BUTTON 11,1,Q$(II+NX),(l0,20*II-5)-(480,20*II+10),2 
NEXT II 

IF NX+12<NQ THEN BUTTON 13,1."MORE".(80,260)-(200.280),3 

BUTTON 14,1,"EXIT",(300,260)-(420,280),3 

PM6: IF DIALOG(0) <> 1 THEN PM6 

KCH - DIALOG(1):BUTTON KCH,2 

IF KCH-13 THEN NX-NX+12:GOTO PM5 

IF KCH-14 THEN PM9 

FC-KCH+NX:WINDOW 3,Q$(FC),,1 

BUTTON 1.1,"EXIT",(430,270)-(490,290),3 

JJ - INT((FC-1)/16) + 1 

KK = ((FC-1) MOD 16) + 1 

FOR HH - 1 TO 3 

FOR II - 1 TO NC 

TBC - CR(HH,II,JJ) AND MK(KK) 

IF TBC - 0 THEN PM6A 

IF H$(11) - PH$ THEN PM6A 

PRINT SPC(1);T$(HH);SPC(1);H$(II) 

PH$ - H$(II) 

PM6A: NEXT II 

NEXT HH 

PM7: IF DIALOG(0) <> 1 THEN PM7 

KCH-DIALOG(1) : IF KCHol THEN PM7 
BUTTON 1,2 

PM9: WINDOW CLOSE 3 

RETURN 
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PAU: BUTTON 1,1,"MORE",(430,270)-(490,290),3 

PA1: IF DIALOG(0)<>1 THEN PA1 

KCH=DIALOG (1) : IF KCHol THEN PA1 
BUTTON 1,2:BUTTON CLOSE 1:RETURN 

REM *** GRAPHICS FOR BOARD-AND-BATTEN FRONT DOOR *** 

G1: LINE (75,13)-(117,87),,B 

FOR I ■ 1 TO 6 

LINE (75+1*6,13)-(75+I*6,87) 

NEXT I 
RETURN 

REM *** GRAPHICS FOR RECESSED PANELS IN FRONT DOOR *** 
G2: LINE (75.12)-(117,88),,B 

FOR I - 1 TO 4 

LINE (84,6+16*I)-(92,16+16*1),,B 
LINE (98,6+16*I)-(106,16+16*1),,B 
NEXT I 
RETURN 

REM *** PILASTERS ON EACH SIDE OF FRONT DOOR *** 

G3: LINE (80,20)-(112,80).,B 

LINE (69,20)-(74,80),,B 

LINE (118,20)-(123,80),,B 

LINE (67,80)-(76,83),,B 

LINE (116,80)-(125,83),,B 

LINE (78,80)-(114,83),,B 

LINE (67,17)-(76,20),, B 

LINE (116,17)-(125,20),,B 

RETURN 


REM *** MASKS FOR BIT MANIPULATION *** 

DATA &H8000,&H4000,&H2000,&H1000 
DATA &H800,&H400,&H200,&H100 
DATA &H80,&H40,&H20,&H10 
DATA &H8.&H4.&H2.&H1 

REM *** LIST OF ARCHITECTURAL FEATURES *** 

REM *** DATE OF CONSTRUCTION *** 

DATA 1,"before 1820" 

DATA 2,"1820 to 1880" 

DATA 3,"1880 to 1940" 

DATA 4,"ofter 1940" 

REM *** ROOF SLOPE *** 

DATA 5,"flat roof" 

DATA 6,"low slope roof" 

DATA 7,"moderate slope roof" 

DATA 8,"steep slope roof" 

DATA 9."several different roof slopes" 

REM *** COMPOSITION OF EXTERIOR WALLS *** 

DATA 10,"wood exterior" 

DATA 11,"stone exterior" 

DATA 12,"brick exterior" 

DATA 13,"stucco or adobe exterior" 

DATA 14,"combination of wood and masonry or stucco" 

DATA 15,"unconventionaI exterior cladding" 

REM *** JUNCTION OF ROOF AND EXTERIOR WALL *** 

DATA 16,"no roof overhang" 

DATA 17,"parapet at roof-line" 

DATA 18,"slight overhang with exposed rafters" 

DATA 19,"slight overhang with boxed eaves" 

DATA 20,"wide overhang with exposed rafters" 

DATA 21,"wide overhang with boxed eaves" 

DATA 22,"unusual roof-wall junction" 

REM *** ENTRYWAY *** 

DATA 23,"a board-and-batten front door" 

DATA 24,"six or eight recessed panels in the front door" 

DATA 25,"pi I asters on each side of the front door" 

DATA 26,"a pediment (crown) above the front door" 

DATA 27,"a front door split Into upper and lower halves" 

DATA 28,"more than one external front door" 

DATA 29,"pal red entry doors" 

DATA 30,"a semi-circular or elliptical fanlight over the front door" 
DATA 31,"slender columns supporting a forward-extending pediment" 
DATA 32,"small rectangular windows on either side of the front door" 
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DATA 33,"a round-arched front doorway" 

DATA 34,"ornate decorations on or around the front door" 

DATA 35,"a recessed or obscurred main entrance" 

DATA 36,"a row of small, rectangular glass panes above the front door" 

DATA 37,"an entryway dominated by a large, formal portico (entry porch)" 

DATA 38,"a fancy metal canopy extending forward above the front door" 

DATA 39,"cant I Ievered (unsupported) section of house, roof, or balcony" 

REM *** FRONT PORCH *** 

DATA 40,"a full-height (ground to roof-line) entry porch" 

DATA 41,"a large, one-story front porch" 

DATA 42,"a porch wrapping around more than one side of the house" 

DATA 43,"cI assicaI (Roman) columns" 

DATA 44,"porch roof supported by heavy, squared columns" 

DATA 45,"porch roof supported by delicate, turned columns" 

DATA 46,"spindled porch railings" 

DATA 47,"porch roof supports which look like bundles of sticks flared at the top" 
DATA 48,"a second-story porch (balcony) with balustrade" 

DATA 49,"lacy spandrels (gingerbread) along porch roof-line" 

DATA 50,"no front porch" 

DATA 51,"porch roof supported by plain, slender, wooden columns" 

DATA 52,"a porch which covers the entire front facade" 

DATA 53,"rough-hewn porch supports, roof beams, and window lintels" 

DATA 54,"visor-shaped, horizontal extension along front of house" 

REM *** WINDOWS *** 

DATA 55,"one or more palladian windows" 

DATA 56,"one or more oriel windows" 

DATA 57,"one or more bay windows" 

DATA 58,"a large, rectangular picture window" 

DATA 59,"metal casement windows set flush with exterior wall" 

DATA 60,"a window with a large pane bounded by many smaller panes" 

DATA 61,"doubIe-hung windows with multi-pane glazing" 

DATA 62,"windows grouped in side-by-side pairs" 

DATA 63,"tall, narrow windows with multi-pane glazing" 

DATA 64,"three or more contiguous windows" 

DATA 65,"upper-story windows less elaborate than first-story ones" 

DATA 66,"horIzontaI window openings with many rectangular panes" 

DATA 67,"windows constructed of glass blocks" 

DATA 68,"windows with many, small, diamond-shaped panes" 

DATA 69,"windows with blank lower panes and patterned upper panes" 

DATA 70,"segmentaI arches above windows" 

DATA 71,"rounded arches above windows" 

DATA 72,"pointed arches above windows" 

DATA 73,"label molding above windows" 

DATA 74,"hood molding above windows" 

DATA 75,"bracketed awnings above windows" 

DATA 76,"pedimented windows" 

DATA 77,"small iron balconies at the base of window openings" 

DATA 78,"flat lintels above window openings" 

DATA 79,"round or elliptical windows" 

REM *** GENERAL ARCHITECTURAL FEATURES *** 

DATA 80,"an irregular roof shape" 

DATA 81,"a second story which partially overhangs the first story" 

DATA 82," a round or polygonal tower at one corner of the facade" 

DATA 83,"symmetricaIly placed windows about a centered front door" 

DATA 84,"two or more front-facing gables" 

DATA 85,"a prominent gable on the front facade" 

DATA 86,"upper and lower stories with different exteriors" 

DATA 87,"one or more pedimented dormers" 

DATA 88,"a sculptured (fancy shape) dormer" 

DATA 89,"ground to roof-line pilasters" 

DATA 90,"cross gables (90 degree angle from each other)" 

DATA 91,"a gambrel roof (dual pitched gables)" 

DATA 92,"a mansard roof (hipped with differing upper and lower slopes)" 

DATA 93,"a hipped roof" 

DATA 94,"flared eaves" 

DATA 95,"rounded ceramic roof tiles" 

DATA 96,"flat ceramic roof tiles" 

DATA 97,"wooden roof shingles" 

DATA 98,"a thatched or false-thatched roof" 

DATA 99,"exterior walls arranged in an octagonal shape" 

DATA 100,"wooden shingles covering a curved or rounded exterior wall" 

DATA 101,"a prominent round tower with a conical roof" 

DATA 102,"a prominent square, hexagonal, or octagonal tower" 

DATA 103,"a long, sprawling floor plan (ranch style)" 

DATA 104,"an attached garage" 

DATA 105,"wide masonry columns supporting the house" 

DATA 106,"a simple rectangular floor plan and a side-gabled roof" 
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DATA 107,"o multi-directional shed roof" 

DATA 108,"three different floor levels In a two-story house (split level)" 
DATA 109,"a central wing projecting forward from the front facade" 

DATA 110,"two small wings at either end with a recessed central entryway" 
DATA 111,"two or more stories" 

DATA 112,"wall cladding which extends up into the gable without a break" 
DATA 113,"graduaIly curved vertical corners" 

DATA 114,"a long horizontal ribbon of connecting windows" 

REM *** ROOF-LINE ORNAMENTATION *** 

DATA 115,"ornamentaI brackets under the eaves" 

DATA 116,"modi I I ions or dentils under the eaves" 

DATA 117,"decorated verge boards" 

DATA 118,"trusses in the gables" 

DATA 119,"false beams at the end of the gables" 

DATA 120,"spindlework detailing (gingerbread) in the gables" 

DATA 121,"decorative terra cotta panels on the face of the gables" 

DATA 122,"decoratIve half-timbering in the gables" 

DATA 123,"a roof-line balustrade" 

DATA 124,"a wide band of trim under the eaves" 

DATA 125,"a small, horizontal ledge (coping) at the roof line" 

DATA 126,"parapeted gables without half-timbering" 

DATA 127, "fancy, ornate decorative detailing along the roof-line" 

DATA 128, "horizontal rectangular openings just below the roof-line" 

DATA 129,"an eyebrow dormer" 

REM *** EXTERIOR WALL DECORATIONS *** 

DATA 130,"decorative half-timbering on upper-stories" 

DATA 131,"exterior details which avoid a smooth-walled appearance" 

DATA 132,"patches of patterned or textured shingles" 

DATA 133,"masonry walls with patterned brickwork or stonework" 

DATA 134,"brackets accentuating simulated upper-story overhang" 

DATA 135,"wood shingle wall cladding" 

DATA 136,"quoins decorating corners of masonry exterior" 

DATA 137,"a belt course on masonry exterior" 

DATA 138,"gar Iands or other floral decorations on exterior" 

DATA 139,"rectanguI or shutters along side the windows" 

DATA 140,"patterned stickwork decorations on exterior walls" 

DATA 141,"wooden roof beams projecting from top of exterior wall" 

DATA 142,"zigzag, chevron, or lozenge decorations on exterior" 

DATA 143,"cornice and facade detailing emphasizing horizontal lines" 

DATA 144,"dormer windows on the steep lower slope of a mansard roof" 

DATA 145,"hipped dormer" 

DATA 146,"shed dormer" 

DATA 147,"exterior detailing with a vertical emphasis" 

DATA 148,"small towers and other vertical projections on the roof" 

DATA 149,"fIoor-to-ceiIing windows" 

REM *** ROOF-TOP DECORATIONS *** 

DATA 150,"a roof-top cupola" 

DATA 151,"a pinnacle on the roof" 

DATA 152,"casteI I ations on the roof" 

DATA 153,"metal roof cresting" 

DATA 154,"spires projecting above one or more gables" 

DATA 155,"a large onion-shaped (Turkish) dome on the roof" 

DATA 156,"decoratIve chimney pots" 

DATA 157,"a prominent, tall, decorative chimney" 

DATA 158,"a wide, flat, plain chimney" 

DATA 159,"a roof-top balustrade" 

DATA 160,"large chimneys at both ends of the house" 

DATA 999 

REM *** LIST OF CLASSIFIERS *** 

DATA 1, "Queen Anne Victorian", 35 
DATA 3,8,80,-83,999 
DATA 41,131,999 

DATA 14,42,43,45,48,49,55,57,60,69,82.84,116,117,157 

DATA 118,120,121,122,132,133,134,153,999 

DATA 2, "Tudor", 30 

DATA 3,8,-41,999 

DATA 90,157,112,999 

DATA 12,23,33,63,64,98,126,130,156,999 

DATA 3, "Italian Renaissance", 30 

DATA 3,21,93,999 

DATA 6,-10,115,999 

DATA 25,26,65,71,76,109,110,136,137,999 
DATA 4, "Italian Renaissance", 30 
DATA 3,5,11,999 
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DATA 83,116,123,999 

DATA 25,26,43,44,65,71,76,136,137,999 

DATA 5, "Northern Postmedieval English", 25 

DATA 1,8,16,999 

DATA 10,23,68,106,111,999 

DATA 81,135,157,999 

DATA 6, "Southern Postmedieval English", 25 

DATA 1,8,16,999 

DATA 23,68,106,999 

DATA 12,111,160,999 

DATA 7, "Urban Dutch Colonial", 30 

DATA 1,999 

DATA 8,12,17,106,-111,146,999 

DATA 27,61,91,160,999 

DATA 8, "Rural Dutch Colonial", 30 

DATA 1,999 

DATA -10,106,999 

DATA 27,61,91,94,-111,146,999 

DATA 9, "Urban French Colonial", 35 

DATA 50,999 

DATA 1,8,13,106,-111,999 

DATA 17,28,29,30,63,94,999 

DATA 10, "Rural French Colonial", 30 

DATA 1,999 

DATA 8,13,41,999 

DATA 29,51,63,92,105,999 

DATA 11, "Spanish Colonial", 25 

DATA 6,-10,999 

DATA 1,28,-34,95,999 

DATA 23,48,999 

DATA 12, "Spanish Colonial", 30 

DATA 5,-10,17,999 

DATA 1.28,-34,-111,999 

DATA 23,41,141,999 

DATA 13, "Georgian", 40 

DATA 1,-30,-62,111,999 

DATA 7,19,61,83,999 

DATA 24,25,26,36,54,76,85,87,89.91,106,116,136,137,159,999 
DATA 14, "Adam", 40 
DATA 1,-62,999 
DATA 7,19,30,61,999 

DATA 24,25,31,32.55.77,78,83,85,116,123,127,137,138,139.999 

DATA 15, "Early Classical Revival", 35 

DATA 37,43,83,999 

DATA 1,7,19,30,40,999 

DATA 24,25,48,79.116,123.999 

DATA 16. "Greek Revival", 35 

DATA 2,-30,124,999 

DATA 6,19,32,43,999 

DATA 25,36,40,48.52,128,999 

DATA 17, "Gothic Revival", 40 

DATA 2,8,999 

DATA 10,18,41,72,90,112,999 

DATA 56,57,73,84,85,102.117,118.999 

DATA 18, "Gothic Revival", 30 

DATA 2,-10,-13,999 

DATA 102,152,999 

DATA 32,72,73.151.999 

DATA 19, "Italianate", 35 

DATA 2,999 

DATA 6,111,115,999 

DATA 25,29,32,41,43.62.72,74,75,85,102,128,150,999 

DATA 20. "Egyptian Revival", 25 

DATA 2,-10,47,999 

DATA 6,111,999 

DATA 25,62,78,115,116,999 

DATA 21, "Oriental Revival", 25 

DATA -10,93,155,999 

DATA 2,72,133,999 

DATA 115 999 

DATA 22,*"Swiss Chalet Revival", 25 

DATA 6,10,20,999 

DATA 2,127,999 

DATA 48,140,999 

DATA 23, "Octagon", 25 

DATA 2,99,999 


318 BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER 1986 



November 


DATA 6,21,93,999 

DATA 41,42,115,150,999 

DATA 24, "Second Empire Victorian", 35 

DATA 2,144,999 

DATA 9 92 115 999 

DATA 25,29,41 *,57,62,71,74,75,79,102,109,136,137,150,999 

DATA 25, "Stick Victorian", 35 

DATA 10,140,999 

DATA 2,8,18,90,999 

DATA 41,57,75,94,102,118,999 

DATA 26, "Shingle Victorian", 35 

DATA 3,135,999 

DATA 7,41,80,-83,999 

DATA 55.57,64,82,100,129.145,999 

DATA 27, "Richardsonian Romanesque", 30 

DATA 3,11,999 

DATA 71,-83,101,999 

DATA 43,64,126,129,151,999 

DATA 28, "Folk Victorian", 30 

DATA 3,10,999 

DATA 7,41,49,999 

DATA 19,45,46,83,115,999 

DATA 29, "Colonial Revival", 33 

DATA 61,999 

DATA 3,7,19,999 

DATA 25,26,31,32,54,57,62,71,81,83,87,91,109,116,135,136.146,999 

DATA 30, "Neoclassical", 33 

DATA 40,43,999 

DATA 3.7,19,61,83,999 

DATA 25,26,32,116.123,999 

DATA 31, "Chateauesque", 35 

DATA 3,8,-10,999 

DATA 157,999 

DATA 11,33,71,74,101,126,151,154,999 

DATA 32, "Beaux Arts", 25 

DATA 3,92,138,999 

DATA 11,83,87,999 

DATA 38,76,77,136,999 

DATA 33, "Beaux Arts", 20 

DATA 3,5,138,999 

DATA 11,43,83,123,999 

DATA 71,136,999 

DATA 34, "Beaux Arts", 20 

DATA 3.6,93,138,999 

DATA 11,83,999 

DATA 71,136,999 

DATA 35, "French Eclectic", 30 

DATA 3.8,-10,999 

DATA 19,-90,93,999 

DATA 33,77,83,94,145.157,999 

DATA 36, "French Eclectic", 35 

DATA 3,8,-10.101,999 

DATA 19,-90,93,999 

DATA 33,64,81,94,130,157,999 

DATA 37, "Mission", 25 

DATA 3,999 

DATA 7,13,95,999 

DATA 17,20,33,41,44,54,88,102,999 
DATA 38, "Spanish Eclectic", 25 
DATA 3,999 

DATA 6,13,16,-83,95,999 

DATA 23,33,34,71,77,999 

DATA 39, "Monterey", 25 

DATA 6,-93,111,999 

DATA 3,48,999 

DATA 51,86,97,999 

DATA 40, "Pueblo Revival", 25 

DATA 3.5,999 

DATA 13,17,141,999 

DATA 23,53,-83,999 

DATA 41, "Pueblo Revival", 25 

DATA 4,5,999 

DATA 13,17,141,999 

DATA 23,53,-83,999 

DATA 42, "Prairie", 35 
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DATA 3.6,999 

DATA 21,111,143,999 

DATA 34,41,44,64,93,95.119.145,158.999 

DATA 43. “Craftsman", 30 

DATA 3,6,999 

DATA 20 999 

DATA 41!44,64,-93,94,115.118,119,130,146,999 

DATA 44, “Art Moderns", 30 

DATA 3,5,999 

DATA 13,-83,125,143,999 

DATA 67,79,113,999 

DATA 45, “Art Deco", 20 

DATA 3,5,142,999 

DATA 13,999 

DATA 127.147,148,999 

DATA 46, "International", 35 

DATA -1,-2.5.-83,999 

DATA -17,59,-125,999 

DATA 13,35,39.51,114,149,999 

DATA 47, “Minimal Traditional", 25 

DATA 4,-5.-8.999 

DATA 16,85,999 

DATA -111,157,999 

DATA 48, “Ranch", 20 

DATA 4,103,999 

DATA 6,-16.-83.-111,999 

DATA 58,104,139,999 

DATA 49, “Split-Level", 15 

DATA 4,108,999 

DATA 6,-16,999 

DATA 14,104,999 

DATA 50, “Contemporary", 20 

DATA 4,999 

DATA 6,20,999 

DATA 14,147,149,999 

DATA 51, "Shed", 15 

DATA 4,107,999 

DATA 16,999 

DATA 10,35,999 

DATA 52, "Neoeclectic Mansard", 25 

DATA 4,9,92,999 

DATA -10,63.71,999 

DATA 29,30,50,999 

DATA 53, "Neocolonial", 25 

DATA 4,-5,999 

DATA 7,61,111,999 

DATA 81,83,139.999 

DATA 54, "Neo-French", 25 

DATA 4,8,93,999 

DATA -10,63.999 

DATA 71,-83,-104,999 

DATA 55. "Neo-Tudor", 30 

DATA 4,8,999 

DATA -10,63,-83,90,999 

DATA 64,80,84,130,157,999 

DATA 56, "Neo-Mediterranean", 25 

DATA 4,6,-10,999 

DATA 71,999 

DATA 12.13,20,21,29,95,-104,999 

DATA 57, "Neoclassical Revival", 25 

DATA 4,40,999 

DATA 37,43,83,-104,999 

DATA 48,124,136,999 

DATA 58, "Neo-Victorian", 35 

DATA 4,10,-50,111,999 

DATA 45,46,-83,131.999 

DATA 42,49,61,999 

DATA 999 

END 
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RULEXREF.PAS 

"Finding Rules in Data," by Beverly Thompson 
and William Thompson, November 1986, page 149. 


(* Copyright 1984 MicroExpert Systems *) 

(*$V- *)PROGRAM rule_xref ; 

CONST word_size = 30 ; 
goal_size = 38 ; 
max_rule = 100 ; 

TYPE string80 = string[80] ; 
word = string[word_size] ; 
stringl = string[1 ] ; 
byte = 0 .. 255 ; 
counter * 0 .. maxint ; 
item_type = (cond,cone Id) ; 
item_ptr = *item ; 
string_ptr = ^string_rec ; 
string_rec * RECORD 
info : string80 ; 

next_line : string_ptr ; 

END ; item - RECORD 
next : item_ptr ; 

attr : word ; 

CASE boolean OF 

TRUE : ( val : word ; 

kind : item_type ; 

rule_no : counter ) ; 

FALSE : ( prompt.ptr : string_ptr ; 

trans_ptr : string_ptr ; 

val_ptr : item_ptr) ; 

END ; VAR line : string80 ; rule_.fi le : text ; token : word ; etx : 
stringl ; free,attr_list : item_ptr ; biggest_rule : counter ; PROCEDURE 
toupper(VAR s : string80) ; 

VAR 

1 : byte ; BEGIN 
IF length(s) > 0 
THEN 

FOR i 1 TO length(s) DO 
IF s[i] IN ['a' .. * z * 3 

THEN s[i] :« chr(ord(s[i]) - 32) ; END ; (* toupper *) PROCEDURE 
makestr(VAR s : string80 ; len : byte) ; VAR 
old_length : byte ; BEGIN 
old_length :* length(s) ; 

(★$R- *) 

s[0] :* chr(len) ; 

(*$R+ *) 

IF old_length < len 

THEN fiIlchar(s[old_lenath+l],len - old.length,* ') ; END ; (* makestr *) 
FUNCTION tointeger(s : word) : integer ; BEGIN 
IF Iength(s) - 0 
THEN tointeger :■ 0 
ELSE IF s[l] - 
THEN 
BEGIN 

deIete(s,1,1) ; 
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tointeger :■ - tointeger(s) ; 

END 

ELSE IF NOT (s[ 1 ] IN ['0’ .. '9’]) 

THEN 

BEGIN 

de I ete(s,1,1) ; 

tointeger :■ tointeger(s) ; 

END 

ELSE IF length(s) - 1 
THEN tointeger :« ord(s[l]) - ord(’0’) 

ELSE tointeger :« to Integer(copy(s,Iength(s),1)) 

♦ I 0 * to Integer(copy(s,1,length(s)-l)) ; END ; (* tointeger *) PROCEDURE 
st rip.leading.bIanks(VAR s : string80) ; BEGIN 
IF length(s) > 0 
THEN 

IF s[1] = • • 

THEN 

BEGIN 

deIete(s,1,1) ; 

strip.leading.blanks(s) ; 

END ; END ; (* strIp_leadIng_bIanks *) PROCEDURE 

strip_t r a I I 1ng.bIanks(VAR s : string80) ; BEGIN 

IF length(s) > 0 
THEN 

IF s[length(s)] » * * 

THEN 

BEGIN 

deIete(s,Iength(s),1) ; 
strip.tralIIng_blanks(s) ; 

END ; END ; (* strIp.leadIng.bIanks *) FUNCTION on_list(s : word ; list : 

Item.ptr ; VAR at : Item_ptr) : boolean ; FUNCTION fInd_it(I 1st : Item_ptr) : 
boolean ; 

BEGIN 

IF list = NIL 
THEN find.it FALSE 
ELSE IF s = Mst^.attr 
THEN 

BEGIN 

at I 1st ; 
flnd.it :« TRUE ; 

END 

ELSE find.it := find.it(Iist~.next) ; 

END ; (* on.list *) BEGIN 

at := NIL ; 

toupperfs) ; 

makestr(s,word.size) ; 

on_list := f1nd_it(Iist) ; END ; (* on.list *) FUNCTION olloc : item_ptr ; 

VAR 

p : item.ptr ; BEGIN 
IF free = NIL 
THEN new(p) 

ELSE 

BEGIN 

p :* free ; 

free := free^.next ; 

END ; 
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alloc :* p ; END ; (* alloc *) PROCEDURE dispose_item(p : item_ptr) ; 
3EGIN 

p^.next := free ; . ,, a 

free := p ; END ; (* dispose.item *) PROCEDURE remove.item(VAR list : 

item.ptr) ; VAR 

p : item.ptr ; BEGIN 
IF I 1st <> NIL 
THEN 
BEGIN 


p :* list ; 

list :« Iist^.next ; 


dispose.item(p) ; 

END ; END ; (* remove.item *) PROCEDURE remove.iist(VAR 
BEGIN 

IF list <> NIL 
THEN 
BEGIN 

remove_ltem(list) ; 


list 


item_ptr) 


remove.i1st(11st) ; 

END ; END ; (* remove.iist *) PROCEDURE new.item(s1,s2 : string80 ; typ 
: item.type ; 

rule.num : counter ; VAR list : item_ptr) ; VAR 
p : item.ptr ; BEGIN 
makestr(si,word_size) ; 
toupper(sl) ; 
makestr(s2,word_size) ; 
toupper(s2) ; 
p := alloc ; 

WITH p* DO 
BEGIN 

attr :* si ; 
val s2 ; 
kind :« typ ; 
rule_no rule.num ; 

END ; 

p^.next :■* list ; 

list := p ; END ; (* new.itern *) PROCEDURE put_on_end(s1,s2 : string80 ; 
typ : item.type ; rule.no : counter ; 

VAR list : item.ptr) ; BEGIN 
IF Iist = NIL 

THEN new_item(s1,s2.typ.rule.no,Iist) 

ELSE put.on.end(s1.s2,typ,rule.no,Iist*.next) ; END ; (* put.on.end *) 
PROCEDURE read.the.file ; VAR 

error : boolean ; PROCEDURE scanf ; 

PROCEDURE get.line ; 

BEGIN 

read In(ruIe.fiIe,I Ine) ; 

IF eof(rule.file) 

THEN Iine :« etx ; 

END ; (* get.IIne *) 

PROCEDURE get.token ; 

VAR 

i : -1 .. 255 ; 

BEGIN 

strip.leading.bIanks(Iine) ; 

IF length(line) > 0 


THEN 

BEGIN 

I :■ pos(* *, IIne) - 1 ; 


IF I <- 0 


THEN 1 Iength(IIne) ; 
token :■ copy(I Ine,1,1) ; 
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toupper(token) ; 
deIete(IIne,1,I) ; 

END 
ELSE 
BEGIN 
get_lIne ; 
get_token ; 

END ; 

END ; (* get_token *) 

BEGIN 

IF eof(rule_fIle) 

THEN token :« etx 
ELSE get_token ; 

END ; (* scanf *) PROCEDURE at_lIne ; 

TYPE 

info_type « (prmpt,trns,nI) ; 

VAR 

typ : lnfo_type ; 
attr_word : strfng80 ; 

PROCEDURE read_a_llne ; 

BEGIN 

read In(ruIe_fIle,IIne) ; 
writer.*) ; 

END ; (* read_a_IIne *) 

PROCEDURE Insert_attr(s : word ; typ : info_type ; line : strlng80 
VAR list : ltem_ptr) ; 

PROCEDURE put_ln_l1st(VAR p : Item.ptr) ; 

PROCEDURE new_attr_Item ; 

VAR 


s_ptr : strlng_ptr ; 
ptr : Item_ptr ; 

BEGIN 

ptr :» alloc ; 
ptr*.attr := s ; 
new(s_ptr) ; 
s_ptr*.Info :* line ; 
s_ptr*.next_lIne :* NIL ; 
CASE typ OF 
prmpt : BEGIN 
ptr*.prompt_ptr :■ s_ptr ; 
ptr*.trans_ptr := NIL ; 

END ; 

trns : BEGIN 
ptr*.prompt_ptr :« NIL ; 
ptr*.trans_ptr :* s_ptr ; 
END ; 

END ; 

ptr*.val_ptr := NIL ; 
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ptr^.next :* p ; 
p :« ptr ; 

END ; (* new_attr_item *) 

PROCEDURE oId_attr_item ; 

VAR 

s_ptr : string_ptr ; 

PROCEDURE end_insert(VAR p_l1st : string_ptr) ; 

BEGIN 

IF p_l1st = NIL 
THEN p.list :« s_ptr 
ELSE end_insert(p_listnext_line) ; 

END ; (* end_insert *) 

BEGIN 

new(s_ptr) ; 

s_ptr*.Info :* line ; 

s_ptr^.next_line :« NIL ; 

CASE typ OF 

prmpt : end_insert(p*.promptsptr) ; 
trns : end_Insert(p*.transeptr) ; 

END ; 

END ; (* old_attr_item *) 

BEGIN 

IF p - NIL 

THEN new_attr_item 

ELSE IF s < p^.attr 

THEN new_attr_ltem 

ELSE IF s - p^.attr 

THEN oId_attr_item 

ELSE put_in_list(p~.next) ; 

END ; (* put_in_list *) 

BEGIN 

makestr(s,word_size) ; 
put_in_list(Iist) ; 

END ; (* insert_attr *) 

BEGIN 

attr_word ; 

IF token - *©PROMPT* 

THEN typ :« prmpt 
ELSE typ :« trns ; 
scant ; 

WHILE token <> DO 
BEGIN 

attr_word :■ concat(attr_word,token,' ') ; 

scant ; 

END ; 

read_a_llne ; 

WHILE (NOT eof(ruIe_flie)) AND (pos(’©\ Iine) « 0) DO 
BEGIN 

{continued) 


BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 325 




November 


lnsert_ottr(ottr_word,typ,Iine.ottr.l1st) ; 

read.o.line ; 

END ; 
scanf ; 

END ; (* at.lIne *) PROCEDURE rule ; 

VAR 

attr.pred.val : string80 ; 
rule.no : counter ; 
kind : Item.type ; 
num : string[4] ; 
at : item.ptr ; 

PROCEDURE runout ; 

BEGIN 

WHILE (token <> *.*) AND (pos(*@*,token) <> 0) AND (token <> etx) DO 
scanf ; 

END ; (* runout *) 

PROCEDURE error.rtn(err num : byte) ; 

BEGIN 
write In ; 

wr ite(’***** error - rule : *,rule.no : 3,' ***** •) • 

CASE err.num OF 

1 : wrIteIn(*CouIdn* *t find rule number.*) ; 

2 : wrIteln(*Mlsslng **IF**.*) ; 

3 : wrIteln(*MlssIng * *THEN* *.*) ; 

4 : wrIteIn(*CouIdn*’t find an attribute.*) ; 

5 : wrIteIn(*CouIdn * * t find a value.*) ; 

END ; 

runout ; 
error :■ TRUE ; 

END ; (* error.rtn *) 

FUNCTION legal.pred(w : word) : boolean ; 

BEGIN 

Iegal.pred :« (w = *IS*) ; 

END ; (* legal.pred *) 

PROCEDURE attribute ; 

BEGIN 

IF NOT Iegal.pred(token) 

THEN 

BEGIN 

attr :* concat(attr,token, ’ *) ; 
scanf ; 
attribute ; 

END ; 

END ; (* attribute *) 

PROCEDURE predicate ; 

BEGIN 

IF attr « ** 

THEN error.rtn(4) 

ELSE IF Iegal.pred(token) 

THEN 

BEGIN 

pred := token ; 
scanf ; 

END ; 

END ; (* predicate *) 

PROCEDURE value ; 

BEGIN 
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IF pred = * * 

THEN error_rtn(5) 

ELSE IF (token <> '.*) AND (token <> etx) 

AND (token <> ‘AND’) AND (token <> ’THEN*) 

THEN 

BEGIN 

val := concat(vaI,token,' * ) ; 

scanf ; 
value ; 

END ; 

END ; (* value *) 

PROCEDURE clause ; 

PROCEDURE put_in_val_list(s1,s2 : string80 ; kind : item_type ; 

rule_no : counter) ; 

VAR 

at : Item_ptr ; 

PROCEDURE put_in_list(VAR list : Item.ptr) ; 

BEGIN 

IF list = NIL 

THEN new_item(s1,s2,kind.ru Ie_no.list) 

ELSE IF Iist^.val > s2 

THEN new_item(s1,s2.kind.ru Ie_no,list) 

ELSE put_in_list(Iist^.next) ; 

END ; (* put_in_list *) 

PROCEDURE make_new_attr_ltem ; 

VAR 

ptr : item_ptr ; 

PROCEDURE put_ln_attr_lfst(VAR list :item_ptr) ; 

BEGIN 

IF list * NIL 
THEN list ptr 

ELSE IF ptr^.attr < list A .ottr 
THEN 
BEGIN 

ptr^.next :■ list ; 
list :« ptr ; 

END 

ELSE put_in_attr_list(Iist^.next) ; 

END ; (* put_in_attr_list *) 

BEGIN 

[continued] 
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ptr :* alloc ; 

makestr(si,word_size) ; 

toupper(sl) ; 

WITH ptr* DO 
BEGIN 

attr :« si ; 
next :■ NIL ; 
prompt.ptr :* NIL ; 
trans.ptr := NIL ; 
val.ptr :■ NIL ; 

END ; 

put.in.attr.list(attr_l1st) ; 
makestr(s2,word_size) ; 
toupper(s2) ; 

put.in.list(ptr*.val.ptr) ; 

END ; (* make.new.attr.itern*) 

BEGIN 

IF on.list(s1,attr.I 181,at) 

THEN 

BEGIN 

makestr(s2,word.size) ; 
toupper(s2) ; 

put.In.I 1st(at*.val.ptr) ; 

END 

ELSE make.new.attr.ltern ; 

END ; (* put.in.val.list *) 

BEGIN 

attr ” ; 
pred :*='*; 
val := M ; 
attribute ; 
predicate ; 

IF NOT error 

THEN value ; 

IF NOT error 

THEN put.in.val.list(attr,vaI,kind,ru 
END ; (* clause *) 

PROCEDURE condition ; 

BEGIN 

IF NOT error 
THEN 
BEGIN 

kind := cond ; 
clause ; 

IF token = 'AND* 


I e.no 
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THEN 
BEGIN 
scant ; 
condition ; 

END ; 

END ; 

END ; (* condition *) 

PROCEDURE conclusion ; 

BEGIN 

IF NOT error 
THEN 
BEGIN 

kind :* concld ; 
clause ; 

IF token * ’AND’ 

THEN 
BEGIN 
scant ; 
conclusion ; 

END ; 

END ; 

END ; (* conclusion *) 

BEGIN 

rule_no :■ tointeger(token) ; 

IF rule.no > 0 
THEN 

BEGIN 

scant ; 

IF token * 'IF* 

THEN 
BEGIN 
scant ; 
condition ; 

IF (token = ’THEN’) AND (NOT error) 

THEN 
BEGIN 
scant ; 
conclusion ; 

IF (rule.no > biggest.ru Ie) AND (NOT error) 

THEN biggest.ruIe rule.no ; 

END 

ELSE error.rtn(3) 

( continued ) 
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END ELSE error_rtn(2) ; 

END 

ELSE error.rtn(l) ; 

END ; (* rule *) BEGIN 
error :« FALSE ; 
scanf ; 

IF token <> etx 
THEN 
BEGIN 

IF (token - ’©PROMPT’) OR (token -’©TRANS') 

THEN at.lIne 
ELSE rule ; 
wrIte(*.•) ; 
read.the.fiIe ; 

END ; END ; (* read.the.fiIe *) FUNCTION got rule fll 

VAR 

ch : char ; 

rule.name : string80 ; 

FUNCTION flle.ok : boolean ; 

FUNCTION open(VAR fI Ie_Id : text ; file.name : string80) : 

BEGIN 
(*$I- *) 

(* For Apple Pascal 
reset(file.ld,file.name) ; 

*) 

assign(fI Ie.id,fI Ie.name) ; 

reset(fiIe.id) ; 

open :■ (ioresult - 0) ; 

(*$I+ *) 

END ; (* open *) 

BEGIN 

wr i te(* F1 Ie name : ’ ) ; 
read In(ruIe.name) ; 
toupper(ruIe.name) ; 

IF pos(’.TXT’,ruIe.name) - 0 
THEN rule.name :® concat(ruIe.name,*.TXT’) ; 

fI Ie_ok open(ruIe_fI Ie,ruIe_name) ; 

END ; (* fI Ie_ok *) BEGIN 
IF NOT file_ok 
THEN 
BEGIN 

wrIteIn ; 

writeIn('An error has occurred while opening the files.’) 
wrIteIn ; 

write(’Press <ESC> to quit, any other key to continue.') ; 
read(trm,ch) ; 
writeIn ; 

IF ch <> chr(27) 

THEN got_ruIe_files got_ruIe_fiIes 

ELSE got_rule.fi Ies FALSE ; 

END 

ELSE got_ruIe_fiIes TRUE ; END ; (* got.ru Ie_fiIes *) 
initialize ; BEGIN 
, m • * . 

etx[l] :« chr(3) ; 
line := ” ; 
biggest.rule :® 0 ; 
free := NIL ; 

attr.list := NIL ; END ; (* initialize *) PROCEDURE xref 
out.name : string80 ; 
ch : char ; 


es : boolean 


boolean ; 


PROCEDURE 


; VAR 
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out_file : text ; PROCEDURE print.xref(iist : item_ptr) ; 

PROCEDURE print_str(msg : word ; ptr : string_ptr) ; 

PROCEDURE print_s_list(p : string.ptr) ; 

BEGIN 

IF p <> NIL 
THEN 
BEGIN 

writeln(out_file,p^.info) ; 
print_s_llst(p^.next_line) ; 

END ; 

END ; (* print_s_J ist *) 

BEGIN 

IF ptr <> NIL 
THEN 
BEGIN 

writeIn(out_fI Ie,msg) ; 
prlnt_s_list(ptr) ; 
wr itelr»(out_f i le) ; 

END ; 

END ; (* prlnt_str *) 

PROCEDURE prInt_v_list ; 

VAR 

last_val : word ; 

PROCEDURE print_v(ptr : item_ptr) ; 

BEGIN 

IF ptr <> NIL 
THEN 
BEGIN 

IF ptr^.val <> last_val 
THEN 
BEGIN 

wr i te I n(out_f He) ; 

write(out_file.ptr^.val) ; 

last_val :■ ptr^.val ; 

END ; 

wrlte(out_fiIe,ptr*.ruIe_no : 4) ; 
print_v(ptr*.next) ; 

END ; 

END ; (* prlnt.v *) 

BEGIN 

IF I 1st*.val_ptr <> NIL 
THEN 
BEGIN 

wrltelnCout.file # ’Value*,• ’ : word_size - 5,*RuIe(s)’) ; 

(continued) 
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last.val :■ M ; 
print_v(list*.val_ptr) ; 
wr I te In(out_f Me) ; 

END ; 

END ; (* print_v_llst *) 

BEGIN 

IF I 1st <> NIL 
THEN 

BEGIN 

wr i te I n(out_f Me) ; 

writeln(out_fMe,’Attribute : •,IIst^.attr) ; 
wr 1teIn(out_f Me) ; 

print_str(’Prompt : ’,Iist^.prompt_ptr) ; 
prlnt_str('Translation : ’,Mst~.trans_ptr) ; 
pr ! nt_v_J I 81 ; 

IF out_name = 'CON:' 

THEN 
BEGIN 
writeln ; 

write('Press any key to continue. ') ; 
read(trm.ch) ; 
writeln ; 

END ; 

prlnt_xref(listnext) ; 

END ; 

END ; (* print.xref *) BEGIN 
writeln ; 

wr 1te('Output File (<RETURN> for con:) ') ; 
read In(out_name) ; 
toupper(out_name) ; 

IF out_name ■ '' 

THEN out_name :« 'CON:' ; 
assign(out_f ile,out_name) ; 
rewrite(out_flie) ; 

(* For Apple Pascal 

rewrite(out_fiIe,out_name) ; 

*) 

print_xref(attr_l1st) ; 
close(out_fiIe) ; 

(* For Apple Pascal 
cIose(out_fiIe,Iock) ; 

*) END ; (* xref *) BEGIN initialize ; IF got rule files 
THEN 

BEGIN 

read_the_f1 Ie ; 
cIose(ruIe_flie) ; 
xref ; 

END ; END. 
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SAMPLE.TXT 

"Finding Rules in Data," by Beverly Thompson 
and William Thompson, November 1986, page 149. 


© 

trans stem @ 

The stem of the plant@ 

© 

prompt stem @ 

Is the stem of the plant woody or green ?@ 

@ 

trans position @ 

The position of the plant® 

@ 

prompt position @ 

Is the position of the plant upright or creeping ?@ 

@ 

trans one main trunk @ 

There is /not/ one main trunk® 

@ 

prompt one main trunk @ 

Does the plant have one main trunk ?@ 

e 

trans type of plant @ 
the type of the plant® 

@ 

trans broad and flat @ 

The shape of the leaves is /not/ broad and flat@ 

® 

prompt broad and flat ® 

Is the shape of the leaves broad and flat ?® 

© 

trans class @ 

The class of the tree@ 

© 

trans leaf shape @ 

The leaf shope® 

© 

prompt leaf shape @ 

Is the leaf shape needlelike or scalelike ?@ 

® 

trans needle pattern @ 

The pattern the needles form along the branch® 

© 

prompt needle pattern @ 

Is the pattern that the needles form along the branch 
a random one or are the needles Is 2 even lines ?@ 

@ 

trans sI Iver bands @ 

There is /not/ a silver band under each needle® 

@ 

prompt silver bands ® 

Is there a silver band under each needle ?@ 

® 

trans fami Iy @ 

The family of the plant@ 

1 If class is gymnosperm 
and leaf shape is scalelike 
then family is cypress 

2 If class is gymnosperm 
and leaf shape Is needlelike 
and needle pattern is random 
then fami Iy is pine 

.3 If class is gymnosperm 

and leaf shape is needlelike 

and needle pattern is 2 even lines 

and silver bands is yes 

then family is pine 

.4 If class is gymnosperm 

and leaf shape is needlelike 

and needle pattern is 2 even lines 


(continued) 
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and 8 i I ver b 

ands Is no 

then fami Iy is pine 

.5 If type of plant is tree 

and broad 

and flat Is yes 

then class Is anglosperm 

.6 If type of plant is tree 

and broad 

and flat is no 

then class is gymnosperm 

.7 If stem is green 

then type of plant Is herb 

.8 If stem is woody 

and position Is creeping 

then type of plant is vine 

.9 If stem is woody 

and position is upright 

and one main trunk is yes 

then type of plant is tree 

.10 If stem is woody 

and position is upright 

and one main trunk Is no 

then type of plant is shrub 


CONFER.TXT 

"Finding Rules in Data," by Beverly Thompson 
and William Thompson, November 1986, page 149. 


)@ 

trans broad and flat @ 

the shape of the leaves Is /not/ broad and flat@ 

@ 

prompt broad and flat @ 

Is the shape of the leaves broad and flat ?@ 

@ 

trans class @ 

the botanical class the tree belongs to @ 

@ 

trans leaf shape ® 
the leaf shape® 

@ 

prompt leaf shape ® 

Is the leaf shape needlelike or scalelike ?@ 

@ 

trans fami Iy @ 

the botanical family the tree belongs to® 

@ 

trans even pattern @ 

the needles do /not/ line up along two sides of the branch@ 

@ 

prompt even pattern @ 

Do the needles grow in two lines along the sides of the branch ?@ 
@ 

trans siI very Iine @ 

there is /not/ a silvery line underneath the needles@ 

® 

prompt siI very line @ 

Is there a silvery line underneath the needles ?@ 

@ 

trans decurrent @ 

the stem of the needle does /not/ grow down along the twig® 

@ 

prompt decurrent @ 

Do the stems of the needles grow down along the twig ?@ 

® 

trans spray shape @ 

the shape of the leaf spray ® 

@ 

prompt spray shape @ 

Is the shape of the leaf spray round or flat ?@ 
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e 

trans random needles @ 

there are /not/ a few needles scattered along the branch® 

e 

prompt random needles @ 

Are there at least a few needles scattered along the branch ? @ 

® 

trans bundle @ 

the needles are /not/ grouped together in bundles of 2 to 5@ 

@ 

prompt bundle @ 

Are the needles grouped together in bundles of 2 to 5 ?@ 

® 

trans needle scar @ 

the scar left when a needle is removed® 

® 

prompt needle scar @ 

Pull a needle off the twig 

. Is the scar it makes raised or depressed ?® 

® 

trans cross section @ 

the cross section of the needle @ 

@ 

prompt cross section @ 

Pull off a need Ie 

. Is its cross section flat, triangular or 4-sided ?@ 

@ 

trans genus @ 

the botanical genus of the tree@ 

Ilf broad and flat is yes 
then class is angiosperm 

.2 If broad and flat is no 
then class is gymno 
sperm 

3 If class is gymno 

sperm and leaf shape is scalelike 

then fami Iy is cypress 

.4 If class is gymno 

sperm and leaf shape is needlelike 

and even pattern Is no 

then family is pine 

.5 If class Is gymno 
sperm 

and leaf shape is needlelike 
and even pattern is yes 
and siI very line is yes 
then family is pine 

.6 If family is cypress 
and spray shape Is round 
and random needles is yes 
then genus is Juniper 

.7 If class is gymno 
sperm 

and leaf shape is needlelike 
and even pattern is yes 
and siI very line is no 
and decurrent is no 
then family is bald cypress 
and genus is bald cypress 

,8 If class is gymno 

sperm and leof shape Is needlelike 

and even pattern is yes 

and sI I very line is no 

and decurrent is yes 

then famiIy is yew 

and genus is yew 

. 9 If famiIy is cypress 
and spray shape is round 

( continued ) 
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end random needles is no 
then genus is white cedar 

.10 If family is cypress 

and spray shape is flat 

then genus is arbor vitae (thuja) 

.11 If family is pine 
and bundle Is yes 
then genus is pine 

.12 If fami Iy is pine 

and bundle is no 

and siIvery line is yes 

and needle scar is depressed 

then genus Is fir 

.13 If famlly is pine 
and bundle is no 
and s i I very line is yes 
and needle scar is raised 
then genus is hemlock 

.14 If family is pine 
and bundle Is no 

and siIvery line is no 

and cross section is triangular 

then genus Is larch 

.15 If famlly is pine 

and bundle Is no 

and siIvery line Is no 

and cross section is four sided 

then genus is spruce 

.16 If famlly is pine 
and bundle Is no 
and sI I very line is no 
and cross section is flat 
then genus is douglas fir 


CONIFERS.TXT 

"Finding Rules in Data," by Beverly Thompson 
and William Thompson, November 1986, page 149. 


©trans broad and flat 

©the shape of the leaves is /not/ broad and flat 
@ 

@prompt broad and flat 

@Is the shape of the leaves broad and flat ? 

@ 

©trans class 

@the botanical class the tree belongs to 
© 

©trans leaf shape 
@the leaf shape 
@ 

@prompt leaf shape 

@Is the leaf shape needlelike or scalelike ? 

© 

@trans famiIy 

©the botanical family the tree belongs to 
© 

©trans even pattern 

©the needles do /not/ line up along two sides of the branch 
© 

©prompt even pattern 

©Do the needles grow in two lines along the sides of the branch ? 
@ 

@trans s1Ivery Iine 
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©there is /not/ o silvery line underneath the needles 
© 

@prompt silvery line 

©Is there a silvery line underneath the needles ? 

© 

©trans decurrent 

©the stem of the needle does /not/ grow down along the twig 
© 

@prompt decurrent 

©Do the stems of the needles grow down along the twig ? 

© 

©trans spray shape 
©the shape of the leaf spray 
© 

©prompt spray shape 

©Is the shape of the leaf spray round or flat ? 

© 

©trans random needles 

©there are /not/ a few needles scattered along the branch 
© 

©prompt random needles 

©Ar # there at least a few needles scattered along the branch ? 

© 

©trans bundle 

©the needles are /not/ grouped together in bundles of 2 to 5 
© 

©prompt bundle 

©Are the needles grouped together in bundles of 2 to 5 ? 

© 

©trans needle scar 

@the scar left when a needle is removed 
© 

©prompt needle scar 

©Pull off a needle. Is the scar that is left raised or depressed ? 

© 

©trans cross section 
©the cross section of the needle 
© 

©prompt cross section 

©Pull off a needle. Is its cross section flat, triangular or 4-sided ? 

© 

©trans genus 

©the botanical genus of the tree 
© 

1 If broad and flat is yes 
then class is angiosperm 
.2 If broad and flat is no 
then class is gymnosperm 
.3 If class Is gymnosperm 
and leaf shape is scalelike 
then family is cypress 
.4 If class is gymnosperm 
and leaf shape Is needlelike 
and even pattern is no 
then family is pine 
.5 If class is gymnosperm 
and leaf shape is needlelike 
and even pattern is yes 
and silvery line is yes 
then fami Iy is pine 
.6 If family is cypress 
and spray shape is round 
and r 

andom needles is yes 
then genus is juniper 
.7 If class is gymnosperm 
and leaf shape is needlelike 
and even pattern is yes 
and siI very line is no 
and decurrent is no 
then family is bald cypress 
and genus is bald cypress 
.8 If class is gymnosperm 
and leaf shape is needlelike 
and even pattern is yes 

[continued) 
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and sI(very line is no 

and decurrent is yes 

then fami Iy is yew 

and genus is yew 

.9 If fami Iy is cypress 

and spray shape Is round 

and random needles Is no 

then genus is white cedar 

.10 If family is cypress 

and spray shape is flat 

then genus is arbor vitae (thuja) 

.11 If family is pine 

and bundle is yes 

then genus Is pine 

.12 If famlIy Is pine 

and bundle is no 

and siI very line Is yes 

and needle scar is depressed 

then genus is fir 

.13 If famiIy is pine 

and bundle is no 

and siI very line is yes 

and needle scar is raised 

then genus is hemlock 

.14 If family is pine 

and bundle is no 

and 8iIvery line is no 

and cross section is triangular 

then genus Is larch 

.15 If family is pine 

and bundle Is no 

and siIvery line Is no 

and cross section is four sided 

then genus is spruce 

.16 If family is pine 

and bundle Is no 

and siIvery line Is no 

and cross section is flat 

then genus is douglas fir 


INDUCE.DOC 

"Finding Rules in Data," by Beverly Thompson 
and William Thompson, November 1986, page 149. 


INDUCE 


Copyright 1986 - MicroExpert Systems 
Box 430 R.D. 2 
Nassau, NY 12123 


INDUCE implements the ID3 algorithm for the generation of rules from a 
data set as described in the article "Finding Knowledge in Data" in the 
November 1986 Issue of BYTE. 

The program has been tested using Turbo Version 3.01A on an IBM PC. It has 
been run under both DOS 2.1 and Concurrent 4.1 . The source for this program 
is contained in two files, INDUCE.PAS and INDUCE.INC. The program produces 
one overlay file INDUCE.000 . 

INDUCE produces a knowledge base which can be used with MicroExpert. 
MicroExpert is an expert system shell written in Turbo Pascal for the IBM PC 
and Apple II. It Is available for $49.95 and comes with complete source code. 
It can be order by writing to : 

McGraw-HiI I Book Company 
P.0. Box 400 
Hightstown, NJ 08520 

Or calling 1-800-628-004 or in New York state 212/512-2999. 
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We would be pleased to hear your comments, good or bad, or any applications 
and modifications of the program. Contact us at the above address or on BIX. 
Our id is bbt and we may be contacted via BIXmail or by leaving comments in 
the MicroExpert conference. 

Bill and Bev Thompson 


Operation 

To start the program simply switch to the directory containing INDUCE.COM 
and INDUCE.000 and at the DOS prompt type INDUCE and press the ENTER key. The 
screen will clear and the message 

Example File (Press <ENTER> to quit.) : 

will appear. Type in the name of your example file and press the enter key. 

The file name should include the drive and path name if necessary. The default 
extension for example files is ".EX". The program will now read the example 
file. Error messages will be displayed on the screen. The program does not do 
very extensive error checking, so be sure to examine the example files and 
knowledge base to be sure that they make sense. 

Once the file has been read, the program will attempt to classify the 
example set. Each time an attempt is made to classify a partition of the 
example set, a is printed on the screen. The program is not particularly 

fast, so you will see the "."s crawl across the screen. 

You may see a appear on the screen from time to time and then 
disappear. This indicates that garbage collection is in process. The program 
is attempting to reclaim memory which has been used, but is no longer 
accessibIe. 

When the classification process has been completed, the message 
Output the tree to what file (Press <ENTER> for screen) ? 

will appear. You may save the tree to a file or press <ENTER> to print it on 
the screen. The format of the tree is described in the BYTE article. If the 
size of the tree is such that its width exceeds 80 columns, it may not print 
properly. After displaying the tree on the screen, a message telling you to 
press any key to continue will be displayed. To print the tree on the printer 
enter "1st:" as the file name. 

Next, the program will display 

Output the rules to what file (Press <ENTER> for screen) ? 

Enter the name of the file which is to contain the rules. If this file is to 
be a MicroExpert knowledge base, be sure to include the extension ".KB" to the 
file name. The program will also write a series of prompts for the attributes. 

Finally the program will clear the screen and request a new example file. 

At this point you can enter a new example file or press <ENTER> to exit the 
program. 


Examp Ie Files 

Example files are simply Ascii text files which are created with a text 
editor. The program ignores blank lines and comments in the files. Comments 
begin with "(*" and end with "*)". A comment may extend over several lines. 

The first line in the file which is not a comment or a blank line must contain 
the attribute names. The format of this line is 

class name,attrI butel,attribute2. 

The class name must come first, followed by the names of the attributes 
separated by commas. Leading and trailing blanks in attribute are not 
significant. Internal spaces are. Therefore, "dog and cat" Is not the same as 
"dogandcat". The program is also case sensitive, so "Dog" is considered 
different from "dog". The program does not check for duplicate attributes, but 
of course, any knowledge base produced using duplicate attribute names is 
likely to be Incorrect. 


(continued) 
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Following the line containing the attribute names are one or more lines 
containing examples. Each example line contains a class value followed by a 
series of attribute values separated by commas. Each example must fit on one 
line. The general format Is 

class value,value of attr ibutel,vaIue of attrlbute2. 

The attributes must be In the same order as they are listed In the first line, 
although there is no way for the program to check on this. As with attribute 
and class names, internal spaces are significant, leading and trailing spaces 
are not. "don't care" values are Indicated by a 

The following is the contents of the file for the example set in the BYTE 
article: 


(* Example file for Byte Article 21-May-86 *) 

(* Copyright [c] 1986 MlcroExpert Systems 

Box 430 RD 2 
Nassau. NY 12123 *) 

(* Attributes *) 


profit 

.age 

.competItIon 

.type 


(* Examples 

*) 


down 

,o 1 d 

, no 

,software 

down 

• midi 1fe 

.yes 

.software 

up 

,midlife 

, no 

.hardware 

down 

,o 1 d 

.no 

.hardware 

up 

,new 

, no 

,hardware 

up 

,new 

,no 

,software 

up 

.midlife 

,no 

,software 

up 

,new 

.yes 

,software 

down 

.midlife 

.yes 

.hardware 

down 

,o 1 d 

.yes 

,software 


Numerical Attributes 

Numerical attributes are handled in the name manner as symbolic (non- 
numerical) attributes, except that "rnumber" is appended to the attribute 
name. M :number" is removed from the attribute name before printing and will 
not appear in either the tree or the knowledge base. Values for numeric 
attributes must be with in the range +/- 1.0E+37 to +/- 1.0E-37. The numbers 
may be entered in Integer, real or floating point format. The following 
example set demonstrates the use of numerical attributes. There is a "don't 
care" value in the second example. 


(* Numerical Attribute Example file *) 

(* Copyright [c] 1986 MlcroExpert Systems 

Box 430 RD 2 
Nassau. NY 12123 *) 

(* Attributes *) 


profit 

,age:number 

.competition 

.type 


(* Examples 

*) 


down 

,5.0 

,no 

,software 

down 

.2.5 

,* 

,software 

up 

.2.5 

. no 

,hardware 

down 

.5 

, no 

.hardware 

up 

,1 

, no 

,hardware 

up 

.1 

.no 

.software 

up 

.2.5 

.no 

.software 

up 

.1 

.yes 

,software 

down 

.2 

,yes 

.hardware 

down 

.5 

.yes 

,software 
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INDUCE.INC 

"Finding Rules in Data," by Beverly Thompson and 
William Thompson, November 1986, page 149.. 


(* 


Utility Routines 


*) 


FUNCTION open(VAR f : text_file ; f_name : string80) : boolean ; 

(* open a file - returns true if the file exists and was opened properly 
f -file pointer 

f_name - external name of the file *) 

BEGIN 

assign(f,f_name) ; 

(*$I- *) 
reset(f) ; 

(*$I+ *) 

open :» (ioresult » 0) ; 

END ; (* open *) 


FUNCTION is_consoIe(VAR f : text_file) : boolean ; 

(* return true if f is open on the system console 

for details of fibs and fib_ptrs see the Turbo Pascal ver 3.0 reference 
manual chapter 20. This should work under CP/M-86 or 80, but we haven’t 
tried it. *) 

TYPE 

fib - ARRAY [0 .. 75] OF byte ; 

VAR 

fib_ptr : ^fib ; 
dev_type : byte ; 

BEGIN 

fib_ptr :* addr(f) ; 

dev_type :« fib_ptr~[2] AND $07 ; 

is_console :* (dev_type « 1) OR (dev_type * 2) ; 

END ; (* is_console *) 


PROCEDURE strip_leading_blanks(VAR s : string80) ; 
BEGIN 

IF length(s) > 0 
THEN 

IF (s[1] - • •) OR (s[1] - tab) 

THEN 

BEGIN 

deIete(s,1,1) ; 

strip_leadlng_bIanks(s) ; 

END ; 

END ; (* strip_leading_bIanks *) 


PROCEDURE strip_tralIing_bIanks(VAR s : string80) ; 
BEGIN 

IF length(s) > 0 
THEN 

IF (s[length(s)] - * *) OR (s[Iength(s)] « tab) 
THEN 
BEGIN 

deIete(s,Iength(s),1) ; 
strip_tralIing_bIanks(s) ; 

END ; 

END ; (* strip_tra11ing_bIanks *) 


FUNCTION toupper(s : string80) : string80 ; 
(* returns s converted to upper case *) 

VAR 

1 : byte ; 

BEGIN 

IF length(s) > 0 


{continued! 


BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 341 






November 


THEN 

FOR I :« 1 TO Iength(s) DO 
s[i] :■ upcase(s[i]) ; 
toupper :* s ; 

END ; (* toupper *) 


FUNCTION toreal(s : string80) : real ; 

(* converts s to a real number 

This routine uses the Turbo Intrinsic val to do the conversion. 

If s does not contain a legal representation of a number, It returns 

0.0 *) 

VAR 

num : real ; 
code : Integer ; 

BEGIN 

strlp_traiIing_bIanks(s) ; 
strip_leading_bIanks(s) ; 
vaI(s,num,code) ; 

IF code ■ 0 
THEN toreal num 
ELSE toreal :■ 0 ; 

END ; (* toreal *) 


FUNCTION ls_number(s : strlng80) : boolean ; 

(* checks to see If s contains a legitimate numerical string. 
It ignores leading and trailing blanks *) 

VAR 

num : real ; 
code : Integer ; 

BEGIN 

strip_traiIing_bIanks(s) ; 
strip_leading_blanks(s) ; 

IF so * * 

THEN val(s,num,code) 

ELSE code :■ -1 ; 
ls_number :« (code ■ 0) ; 

END ; (* is_number *) 


FUNCTION head(llst : node_ptr) : node_ptr ; 

(* returns a pointer to the first item in the list. 

If the list Is empty. It returns NIL. *) 

BEGIN 

IF I 1st * NIL 
THEN head :* NIL 
ELSE head :* Iist~.head_ptr ; 

END ; (* head *) 


FUNCTION tail(Mst : node_ptr) : node_.ptr ; 

(* returns a pointer to a list starting at the second item in the list. 
Note - taiI( (a b c) ) points to the list (b c), but 

tail( ((a b) c d) ) points to the list (c d) . *) 

BEGIN 

IF Iist = NIL 
THEN tail := NIL 
ELSE 

CASE Iist*.tag OF 

cons_node : tail := I ist~. tai I __p t r ; 
free_node : tail := Iist~.next_free ; 

ELSE taiI := NIL ; 

END ; 

END ; (* taiI *) 


FUNCTION element(list : node_ptr ; elem_no : counter) : node_ptr ; 
(* returns a pointer to the element number elem_no in the list, 
eIement(Iist,1) points to list, 
eIement(Iist,2) is the same as tail(list). *) 

VAR 

i : counter ; 

BEGIN 

FOR i := 1 TO eIem_no - 1 DO 
list := taiI(11st) ; 


342 BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 






November 


eIement :* list ; 
END ; (* element *) 


FUNCTION a I Iocation_size(x : counter) : counter ; 

(* Turbo 3.0 allocates memory in 8 byte blocks, this routine calculates the 
actual number of bytes returned for a request of x bytes. *) 

BEGIN 

a Ilocation_size := (((x - 1) DIV 8) + 1) * 8 ; 

END ; (* allocation_size *) 


FUNCTION node_size : counter ; 

(* calculates the base size of a node. Add the rest of the node to this 
to get the actual size of a node *) 

BEGIN . N 

node_size :« 2 * sizeof(node_ptr) + sizeof(boo Iean) + sizeof(node_type) ; 
END ; (* node_size *) 


FUNCTION normalize(pt : node_ptr) : node_ptr ; 

(* returns a normalized pointer. Pointers are 32 bit addresses. The first 
16 bits contain the segment number and the second 16 bits contain the 
offset within the segment. Normalized pointers have offsets in the range 
$0 to $F (0 .. 15) *) 

VAR 

pt_seg,pt_ofs : integer ; 

BEGIN 

pt_seg := segfpt") + (ofs(pt") DIV 16) ; 
pt_ofs := ofs(pt") MOD 16 ; 
normalize := ptr(pt_seg,pt_ofs) ; 

END ; (* norma Iize *) 


FUNCTION string_val(Iist : node_ptr) : string80 ; 

(* returns the string pointed to by list. If list points to a number 
node, it returns a string representing that number *) 

VAR 

s : string[15] ; 

BEGIN 

IF Iist * NIL 
THEN str1ng_vaI :« * * 

ELSE IF I ist".tag » symbol 
THEN string_vaI :« Iist".string_data 
ELSE IF Iist".tag * number 
THEN 
BEGIN 

str(Iist".num_data : 14,s) ; 
strlng_val :* s ; 

END 

ELSE string_val ' ; 

END ; (* string_vaI *) 


FUNCTION num_va1(1ist : node_ptr) : real ; 

(* returns the number pointed to by list. If list points to a string. 
It returns the numerical value of the string. *) 

VAR 

s : string80 ; 
code : integer ; 
r : real ; 

BEGIN 

IF Iist - NIL 
THEN num_vol 0.0 

ELSE IF Iist".tag - number 
THEN num_vaI :« I Ist".num_data 
ELSE IF Iist".tag » symbol 
THEN num.val toreal(IIst".string_data) 

ELSE num_val :■ 0.0 ; 

END ; (* num_val *) 


FUNCTION attrlb_vaIue(p : node_ptr) : string80 ; 

(* This routine is used by print_rule and print.tree to strip off 
'jnumber* from an attribute name. *) 

( continued ) 
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8EGIN 

IF pos(*:NUMBER*,toupper(strlng_val(p))) > 0 
THEN attrlb_value :■ copy(strIng_vaI(p), 

1,pos(•iNUMBER’,toupper(string_val(p))) - 1) 
ELSE attrib_value :® strlng_vaI(p) ; 

END ; (* attrib_value *) 


FUNCTION tag_vaIue(Ilst : node_ptr) : node_type ; 

(* returns the value of the tag for a node. *) 
BEGIN 

IF I 1st - NIL 

THEN tag_value :* free_node 
ELSE tag_vaIue :* IIst".tag ; 

END ; (* tag_value *) 


FUNCTION match_lIsts(Iist1,Iist2 : node_ptr) : boolean ; 

(* returns true If listl and Ilst2 are Identical. 

Two lists are Identical If they are both NIL or If their heads match 
and match_lists returns true for thler tails. *) 

BEGIN 

IF (listl - NIL) AND (I Is12 - NIL) 

THEN match^lists true 

ELSE IF (listl - NIL) OR (Iist2 - NIL) 

THEN match_J ists := false 

ELSE IF tag_vaIue(head(Iist1)) <> tag_vaIue(head(I Ist2)) 

THEN match_lists false 

ELSE 

CASE tag_vaIue(head(I Ist1)) OF 

symbol : IF string_vaI(head(Iist1)) - string_vaI(head(I Is12)) 

THEN match_IIsts := match_lists(taI I(Iist1),taI I(Iist2)) 
ELSE match_Msts :» false ; 

number : IF num_vaI(head(I Ist1)) = num_vaI(head(Iist2)) 

THEN match_lists := match.lists(taiI(Iist1),taiI(Iist2)) 
ELSE match_lists := false ; 
cons_node : IF match_lists(head(I 1st 1),head(Iist2)) 

THEN match_lists :» match.lists(taiI(I 1st 1),taiI(Iist2)) 
ELSE match_lists := false ; 

END ; 

END ; (* match_lists *) 


FUNCTION on — llst(s : string80 ; list : node_ptr) : boolean ; 

(* checks to see if s is on the list, list, s is on the list if it 

matches the head of the list or if on_Iist(taiI(Iist)) returns true. 

BEGIN 

IF list = NIL 
THEN on_list :« false 
ELSE IF s = string_vaI(head(Iist)) 

THEN on_list :» true 
ELSE on_list :* on_list(s,tai1(1ist)) ; 

END ; (* on_l1st *) 


PROCEDURE print_list(Iist : node_ptr) ; 

(* recursively traverses the list and prints its elements. This is 
not a pretty printer, so the lists may look a bit messy. *) 

VAR 

p : node_ptr ; 

BEGIN 

IF list <> NIL 
THEN 

CASE Iist".tag OF 

symbol : write(string_vaI(Iist),* ') ; 
number : write(num_vaI(Iist) : 6,* ') ; 
cons_node : BEGIN 

wr i te('(*) ; 
p := list ; 

WHILE p <> NIL DO 
BEGIN 

print_list(head(p)) ; 
p taiI(p) ; 

END ; 

write(') *) ; 

END ; 
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END ; 

END ; (* print_lIst *) 


PROCEDURE get_memory(VAR p : node_ptr ; size : counter) ; 

(* On exit p contains a pointer to a block of a I Iocation_size(size) bytes. 
If possible this routine tries to get memory from the free list before 
requesting it from the heap *) 

VAR 

blks : counter ; 
a I Iocated : boo Iean ; 

PROCEDURE get_f rom_.fr ee( VAR list : node_ptr) ; 

(* Try and get need memory from the free list. This routine uses a 

first-fit algorithm to get the space. It takes the first free block it 
finds with enough storage. If the free block has more storage than was 
requested, the block is shrunk by the requested amount. *) 

BEGIN 

IF Iist <> NIL 
THEN 

IF Iist^.block.cnt >- (blks - 1) 

THEN 

BEGIN 

p := norma Iize(ptr(seg(Iist^),ofs(Iist~) ♦ 

(Iist~.block_cnt - blks + 1) * 8)) ; 

IF Iist^.bIock_cnt = blks - 1 
THEN list Iist*.next_free 

ELSE Iist".block_cnt :* Iist".bIock_cnt - blks ; 
a I Iocated := true ; 

total_free :* total_free - (blks * 8.0) ; 

END 

ELSE get_from_free(Iist^.next_free) ; 

END ; (* get_from_.free *) 

BEGIN 

blks :« ((size - 1) DIV 8) + 1 ; 
a I I ocated := false ; 
get_from_free(free) ; 

IF NOT a I located 
THEN getmem(p,bIks * 8) ; 

END ; (* get_memory *) 


FUNCTION alloc_str(s : string80) : node_ptr ; 

(* Allocate storage for a string and return a pointer to the new node. 
This routine only allocates enough storage for the actual number of 
characters In the string plus one for the length. Because of this, 
concatenating anything to the end of a string stored in a symbol node 
will lead to disaster. Copy the string to a new string do the 
concatenation and then allocate a new node. *) 

VAR 

pt : node_ptr ; 

BEGIN 

get_memory(pt,a I Iocatlon_size(sizeof(node_type) + sizeof(boo Iean) + 

length(s) + 1)) ; 

pt^.tag :* symbol ; 

pt^.string_data :« s ; 

a Iloc_str :* pt ; 

END ; (* alloc_str *) 


FUNCTION alloc_num(r : real) : node_ptr ; 

(* Allocate storage for a real number and return a pointer to the new node. *) 
VAR 

pt : node_ptr ; 

BEGIN 

get_memory(pt,a I Iocation_size(sizeof fnode_type) + sizeof(boo Iean) + 

sizeof(real))) ; 

pt^.tag :■ number ; 
pt*.num_data :* r ; 
alloc_num :* pt ; 

END ; (* alloc_num *) 


[continued) 
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FUNCTION cons(new_node,1ist : node.ptr) : node.ptr ; 

(* Construct a list. This routine allocates storage for a new cons node, 
new.node points to the new head of the list. The tail pointer of the 
new node points to list. This routine adds the new cons node to the 
beginning of the list and returns a pointer to it. The list described 
in the comments at the beginning of the program could be constructed 
as cons(aIloc.str(*A*),cons(a Iloc.str(’B’),cons(aIloc.str('C*),NIL))). *) 

VAR 

p : node.ptr ; 

BEGIN 

get_memory(p,allocation.sIze(node.size)) ; 

p^.tag :* cons.node ; 

p^.head.ptr := new.node ; 

p^.tail.ptr := list ; 

cons :■ p ; 

END ; (* cons *) 


FUNCTION append.list(I Ist1,Iist2 : node.ptr) : node.ptr ; 

(* Append Iist2 to listl. This routine returns a pointer to the 

combined list. Appending is done by consing each item on the first 
list to the second list. This routine is one of the major sources of 
garbage so if garbage collection becomes a problem, you may want to 
rewrite it. *) 

BEGIN 

IF I ist1 - NIL 
THEN append.lIst := Iist2 

ELSE append.llst := cons(head(I Ist1),append.list(taiI(Iist1),Iist2)) ; 
END ; (* append.list *) 


FUNCTION Iist.length(I Ist : node.ptr) : counter ; 

(* returns the length of a list. 

Note - both (A B C) and ( (A B) C D) have length 3. *) 

BEGIN 

IF Iist * NIL 
THEN Iist.length :» 0 

ELSE list.length := 1 + Iist.length(IIst^.tail.ptr) ; 

END ; (* I 1st.length *) 


FUNCTION copy.list(Iist : node.ptr) : node.ptr ; 

(* Returns a pointer to a copy of list. This routine allocates new nodes 
for each item in the original list *) 

BEGIN 

IF list = NIL 
THEN copy.list NIL 
ELSE 

CASE tag.vaIue(Iist) OF 

cons.node : copy.list :* cons(copy.list(head(Iist)),copy.lIst(taiI(Iist))) 
number : copy.list a I Ioc_num(num_vaI(Iist)) ; 

symbol : copy.list :* alloc.str(strIng.val(I 1st)) ; 

END ; 

END ; (* copy.list *) 


PROCEDURE coI Iect.garbage ; 

(* This routine is specific to Turbo Pascal Ver 3.01 

It depends upon the fact that Turbo allocates memory in 8 byte blocks 
on the PC. If you recompile this program on another system be very 
careful with this routine. 

Garbage collection proceeds in three phases: 
unmark - free all memory between the initial.heap'* and the current 
top of the heap. 

mark - mark everything on the saved.list as being in ues. 
release - gather all unmarked blocks and put them on the free list. 
The collector displays a *♦* on the screen to let you know it is 
operating. *) 

FUNCTION lower(p1,p2 : node.ptr) : boolean ; 

(* returns true If pi points to a lower memory address than p2 *) 

BEGIN 

pi :® norma 11ze(p1) ; 
p2 :* norma Iize(p2) ; 
lower := (seg(pl^) < seg(p2~)) OR 

((seg(pl^) = seg(p2~)) AND (ofs(pl^) < ofs(p2~))) ; 

END ; (* lower *) 
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PROCEDURE mark(Ii st : node_ptr) ; 

(* Mark the blocks on list as being in use. Since a node may be on several 
lists at one time, if it is already marked we don’t continue processing 
the taiI of the list. *) 

BEGIN 

IF list <> NIL 
THEN 
BEGIN 

IF NOT list~.in_use 
THEN 
BEGIN 


1ist*.in_use 

:= true ; 

IF list^.tag 

» cons_node 

THEN 


BEGIN 


mark(head( 

;n«0) ; 

mark(tai11 

ilist)) ; 


END ; 
END ; 

END ; 

END ; (* mark *) 


PROCEDURE unmark_mem ; 

(* Go through memory from initial_heap~ to HeapPtr^ and mark each node 
as not in use. The tricky part here is updating the pointer p to point 
to the next cell. *) 


VAR 

p : node_ptr ; 

string_base,node_allocation : counter ; 

BEGIN 

string_base := sizeof(node_type) + sizeof(booIean) 
p :* norma Iize(initial_heap) ; 
node_aI Iocat ion :* al locat ion__s i ze(node_s ize) ; 
WHILE lower(p.HeapPtr) DO 
BEGIN 

p~.in_use :* false ; 

CASE p^.tag OF 


cons_node 
free_node 
number 


symboI 


normal izefptrfsegfpM ,ofs(p^) + node_aI locat ion)) ; 
norma I Ize(ptr(seg(p^),ofs(p^) + (p*.bIock_cnt + 1) * 8)) 
normalize(ptr(sea(p~), 
ofs(p^) + 

a Ilocation_size(string_base + sizeof(reaI)))) ; 
normalize(ptr(seg(p A ), 
ofs(p^) + 

a I locatlon_s ize(string_base + 

Iength(p*.string_data) + 1))) ; 


END ; 

END ; 

END ; (* unmark_mem *) 


PROCEDURE release_mem ; 

(* This procedure does the actual collection and compaction of nodes. 

This is the slow phase of garbage collection because of all the pointer 
manipulation. *) 

VAR 

heap_top : node_ptr ; 

string_base,node_allocation.string_alIocation,bIock_aI location : counter ; 

PROCEDURE free_memory(pt : node_ptr ; size : counter) ; 

(* return size bytes pointed to by pt to the free list. If pt points to 
a block next to the head of the free list combine it with the top 
free node. total__free keeps track of the total number of free bytes. *) 

VAR 

blks : counter ; 

BEGIN 

blks :« ((size - 1) DIV 8) + 1 ; 
pt^.tag :* free_node ; 

IF normalize(ptr(seg(pt^),ofs(pt^) + 8 * blks)) ■ free 
THEN 
BEGIN 

pt*.next_free :* free~.next_free ; 
pt*.block_cnt free~.block_cnt + blks ; 
free :» pt ; 

END 


(continued) 
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ELSE IF normal I zefptr(seg(free~),ofs(free~) + 8 * (free~.bIock_cnt + 1))) 
norma I Ize(pt) 

THEN free~.block_cnt :* free^.block_cnt + blks 
ELSE 
BEGIN 

pt*.next_free :■ free ; 
pt^.block_cnt :■ bike - 1 ; 
free pt ; 

END ; 

total_free :■ total_free + (bike * 8.0) ; 

END ; (* free_memory *) 

PROCEDURE do_release ; 

(* This routine sweeps through memory and checks for nodes with 
ln_use * false. *) 

VAR 

p : node_ptr ; 

BEGIN 

p :*= norma I i ze( In 11 i a l_heap) ; 

WHILE lower(p,heap_top) DO 
CASE p^.tag OF 
cons_node : BEGIN 

IF NOT p*.Infuse 
THEN free_memory(p,node_sIze) ; 
p :« normalize(ptr(seg(p^),ofs(p^) + node_allocation)) ; 
END ; 

free_node : BEGIN 

block_aIlocatIon :* (p^.block_cnt + 1) * 8 ; 
free_memory(p t block_aI location) ; 

p :« norma I Ize(ptr(seg(p~),ofs(p*) + block_aIlocation)) ; 
END ; 

number : BEGIN 

block_allocatIon :■ a I Iocation_size(string_base + 

sIzeof(reaI)) ; 

IF NOT p*.in_use 

THEN free_memory(p,block_allocation) ; 
p :« norma Iize(ptr(seg(p~),ofs(p~) + block_allocation)) ; 
END ; 

symbol : BEGIN 

strIng_aI IocatIon :■ a I Iocation_size(string_base + 

Iength(p~.string_data) + 1) ; 

IF NOT p~.infuse 

THEN free_memory(p,string_base + Iength(p~.string_data) 

+ i) ; 

p := normalize(ptr(seg(p^),ofs(p~) + string_allocation)) ; 
END ; 

END ; 

END ; (* do_release *) 

BEGIN 

free :« NIL ; 
total_free :■ 0.0 ; 
heap_top := HeapPtr ; 

string_base := sIzeof(node_type) + s i zeof(boo Iean) ; 
node_aI Iocation :■ a I Iocation_size(node_sIze) ; 
do_release ; 

END ; (* release_mem *) 

BEGIN 

wr i te(***) ; 
unmark_mem ; 
mark(saved_Ji st) ; 
release_mem ; 
wr ite(back_space) ; 
clreol ; 

END ; (* coI Iect_garbage *) 


PROCEDURE test_memory ; 

(* This routine activates the garbage collector, if the the total available 
memory (free_list + heap) Is less than a specified amount. Lowering the 
minimum causes garbage collection to be called less often, but if you 
make it too small you may not have enough room left for recursion or any 
temporary lists you need. Using 10000 is probably being overly 
cautious. *) 

BEGIN 

IF (memavail * 16.0) + total_free < 10000 
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THEN collect_garbage ; 

END ; (* test_memory *) 

PROCEDURE wait ; 

(* Just like it says. It waits for the user to press a key before 
continuing. *) 

VAR 

ch : char ; 

BEGIN 
writeIn ; 
wr i te I n ; 

write(*Press any key to continue. *) ; 
read(kbd.ch) ; 
wr ite(return) ; 
clreol ; 

END ; (* wait *) 


(* 


End of utility routines 


*) 


INDUCE.PAS 

"Finding Rules in Data," by Beverly Thompson and 
William Thompson, November 1986, page 149.. 


{. IN+} 

|.PW132{ 

(*$V-,R+,B- *) 

PROGRAM Induce ; 

(* Copyright 1986 - MicroExpert Systems 
Box 430 R.D. 2 
Nassau, NY 12123 *) 

(* Induce implements the ID3 algorithm for the generation of rules from a data 
set as described in the BYTE article "Finding Knowledge in Data". 

This program has been tested using Turbo ver 3.01A on an IBM PC. It has 
been run under both DOS 2.1 and Concurrent 4.1 . 

The source for this program is contained in two files, INDUCE.PAS and 
INDUCE.INC. The program produces one overlay file INDUCE.000 . 

INDUCE produces a knowledge base which can be used with MicroExpert. 
MicroExpert is an expert system shell written in Turbo Pascal for the 
IBM PC and Apple II. It is available for $49.95 and comes with complete 
source code. It can be order by writing to : 

McGraw-HiI I Book Company 
P.0. Box 400 
Hightstown, NJ 08520 

Or calling 1-800-628-004 or in New York state 212/512-2999. 

We would be pleased to hear your comments, good or bad, or any applications 
and modifications of the program. Contact us at the above address or 
on BIX. Our Id is bbt and we may be contacted via BIXmail or by leaving 
comments in the MicroExpert conference. 

Bi I I and Bev Thompson *) 


CONST 

In2 - 0.69314718 ; 
limit - 1.0E-20 ; 
debug - false ; 
back-space - ~H ; 
tob - *1 ; 
eof_mark * ; 

esc - #27 ; 


(continued) 
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quote.chor ■ #39 ; 
left.arrow - #75 ; 
end.key ■ #79 ; 
del.lIne - "X ; 
return « ; 

bell - A G ; 

TYPE 

counter ■ 0 .. max Int ; 
string80 - strlng[80] ; 
string132 - stringfl32l ; 
strlng255 - strlng[255j ; 
text.?lie = text ; 
char.set * SET OF char ; 

node.type ■ (cons.node,symboI.number,free_node) ; 
node.ptr ■ *node ; 
node ■ RECORD 

!n_use : boolean ; 

CASE tag : node.type OF 
cons.node : (tall_ptr : node.ptr ; 

head_ptr : node.ptr) ; 
symbol : (strlng_data : strlng80) ; 

number : fnum.data : real) ; 

free_node : (next.free : node.ptr ; 

block.cnt : counter) ; 

END ; 

(* node is the basic allocation unit for lists. The fields are used as 
foI Iows: 

In.use 

tag 

cons.node 


symboI 

number 
free.node 


- in.use * false tells the garbage collector that this node 
is available for re-use. 

- which kind of node this is. 

- cons.nodes consist of two pointers, one to the head (first item) 
the other to the rest of the list. They are the "glue" which 
holds the list together. The list (A B C) would be stored as 


| .| . |-> | . | . |-> | .| . |-> NIL 

__|- , -|- -|- 

I I I 

V V V 

ABC 

The boxes are the cons nodes, the first part of the box 
holds the head pointer, then second contains the tail. 

- holds string values, we don't actually use the entire 80 
characters in most cases. 

- contains a real number. 

- the garbage collector gathers all unused nodes and puts 
them on a free list. It also compacts the free space into 
contiguous blocks. next.free points to the next free block, 
block.cnt contains a count of the number of contiguous 8 byte free 
blocks which follow this one. *) 


VAR 

example_file : text.file ; 
line : string255 ; 

c_list,examples,attrib_l1st,saved_list,initial_heap,free : node_ptr ; 
total_free : real ; 
no_.of.coIs : counter ; 


(* The important globals are: 

example.file - text file containing the original example set. See the 
documentation file for its format, 
line buffer for reading in the text file 
the classification tree 
the list of examp Ies 

list of attribute names and their values 

list of all items that absolutely must be saved if garbage 


line 
c.list 
examples 
attrib.list - 
saved.list 


collection occurs. Usually has at least the examples and 
attrib.list attcahed to it. 

initial.heap - the value of the heap pointer at the start of the program. 

used by the garbage collector 
free - the list of free nodes. 

total.free - total number of free blocks on the free list. 
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no.of.cols - the total number of attributes + the class attribute in 
the example set. *) 


(*$I induce.inc *) 


PROCEDURE read_from.fi Ie(VAR f : text.file) ; 

(* Read a line form file f and store it in the global variable, line. 

It ignores blank lines and comments. When the end of file is reached 
eof.mark is returned. *) 

CONST , N 

in.comment : boolean ■ false ; (* static *) 


PROCEDURE read.a.line ; 

BEGIN 
(*$I- *) 

read In(f, I ine) ; 

(*$I+ *) 

IF ioresult <> 0 
THEN line :* eof.mark 
ELSE IF pos('(*',line) > 0 
THEN 

IF post’*)’* 1 > ne ) > 0 v / x n 

THEN delete(Iine,pos('(*',Iine),pos('*)Mine) 

ELSE 

BEGIN 

in.comment :* true ; 
line :« " ; 

END ; 

END ; (* read.a.line *) 


pos(' (*',Iine) ♦ 2) 


BEGIN 

line " ; 

IF eof(f) 

THEN line eof.mark 
ELSE 
BEGIN 


read.a.lIne ; 

IF in.comment 
THEN 

IF pos(' * ) '»Iine) > 0 
THEN 
BEGIN 

deIete(Iine,1,pos('*)’,Iine) + 1 
in.comment :■ false ; 


) 


END 

ELSE read.from.fiIe(f) ; 


END ; 

st r1 p.l eading.bIanks(I Ine) ; 
st ri p.t raiIing.bIanks(Iine) ; 
IF Iine - '• 

THEN read.from.file(f) ; 

END ; (* read.from.f iI e *) 


OVERLAY PROCEDURE expand(exampIe.list : node.ptr ; 

VAR new.exampIe.list : node.ptr) ; 

(* Expand “don't care" values into values from attrib.list. 
example.list - unexpanded example set 

new.exampIe.l1st - expanded set *) 

PROCEDURE dup_and_copy(Iist : node_ptr) ; 

(* This routine creates a new version of the current row, pointed to by 
list. If it finds a regular attribute value, it Just appends the value 
to the row it is constructing. If it finds a indicating a 

"don't care" value, it call copy.to.new.l1st to expand the value and 
attach the new rows to new.exampIe.list. 

Notice that we attach anything we don't want to be trashed by the 
garbage collector to the head of saved.list and remove it at the end 
of the routine, copy.to.new.lIst saves new.llst because it calls 
dup.and.copy and that routine might Initiate garbage collection. *) 

VAR 

new.lIst,attr.ptr : node.ptr ; 
copied : boolean ; 
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PROCEDURE copy_to_new_list ; 

(* This routine does the actual expansion. It attaches a value for the 
attribute, pointed to by p, to the row that has been constructed 
so far and attaches the rest of the list to the end of the row. 

H calis dup.and.copy to expand any more **s in the row and finally 
attach the row to the new_example list *) 

VAR ' 

p,new_row : node_ptr ; 

BEGIN 

saved_list :■ cons(new_lIst,saved_list) ; 
copied true ; 
p :■ tall(head(attr_ptr)) ; 

WHILE p <> NIL DO 
BEGIN 

new_row append_lIst(new_list,cons(head(p),tail(list))) • 
dup_and_copy(new_row) ; 
p :» taiI(p) ; 

END ; 

saved_list tail(saved..!1st) ; 

END ; (* copy_to_new_list *) 

BEGIN 

saved_l1st :* cons(I Ist,saved_list) ; 

test_memory ; 

new_list :* NIL ; 

attr_ptr :» attrib_list ; 

copied := false ; 

WHILE (list <> NIL) AND (NOT copied) DO 
IF string_val(head(Iist)) - *♦* 

THEN copy_to_new_list 
ELSE 
BEGIN 

new_list :* append_list(new_l1st,cons(head(IIst),NIL)) : 

Iist :■ tai1(1ist) ; 
attr_ptr :* taiI(attr_ptr) ; 

END ; 

IF NOT copied 

THEN new_exampIe_list :■ append..!ist(new_exampIe.list,cons(new_list,NIL)) 
saved.list :« cons(new_exampIe_list,taiI(saved list)) : 

END ; (* dup_and_copy *) 

BEGIN 

new_example_list :* NIL ; 

WHILE example_Jist <> NIL DO 
BEGIN 

dup_and_copy(head(exampIe_J ist)) ; 

examp Ie_Iist := tail(example list) : 

END ; 

END ; (* expand *) 


OVERLAY FUNCTION confIicts(exampIe_Iist : node_ptr) : boolean ; 

(* Search for conflicts by using match_list to compare each row against 
the rows which follow it in the example list, conflicts returns true 
if a match is found. *) 

VAR 

p : node_ptr ; 
found_match : boolean ; 

PROCEDURE confIict_message ; 

BEGIN 
wrlteln ; 

writeIn('A conflict exists between rows:’) : 
writeln ; 

pr I nt_I i st (head(examp I e__l I st)) ; 

writeln ; 

print_Iist(head(p)) ; 

writeln ; 

writeIn(’Processing cannot continue.*) ; 

END ; (* confIict_message *) 

BEGIN 

found_match := false ; 

WHILE (examp Ie_list <> NIL) AND (NOT found match) DO 
BEGIN ” ' 

p := taiI(examp Ie_list) ; 

WHILE (p <> NIL) AND (NOT found_match) DO 
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IF motch_lists(toiI(heod(exampIe_l1st)),taiI(heod(p))) 
THEN found.match := true 
ELSE p := tail(p) ; 

IF NOT found_match 

THEN examp Ie.l1st := taiI(examp Ie.list) ; 

END ; 

IF found.match 
THEN confIict.message ; 
conflicts :* found.match ; 

END ; (* confIicts *) 


OVERLAY PROCEDURE buiI datable ; 

(* Read the example file and build the attrib.list and examples. The 
format of these two lists is described in the BYTE article mentioned 
at the beginning of the program. This routine doesn’t do much error 
checking, so be careful with your example files. *) 

VAR 

new.row : node.ptr ; 
token : strlng80 ; 

PROCEDURE scan ; 

(* Get a single token from the input line. This procedure strips leading 
and trailing blanks and tabs, but interior spaces are sigificant. 

A token is any string between the first non-space character and a 
comma or end of line. Case is significant in tokens, ’Cat’ and ’cat’ 
will be treated as different values by the program. *) 

VAR 

comma.pos : byte ; 

BEGIN 

strip_leading_blanks(line) ; 

IF line = ' * 

THEN token := ” 

ELSE 

BEGIN 

comma.pos := pos(*,*,Iine) ; 

IF comma.pos > 0 
THEN 
BEGIN 

token :* copy(Iine,1,comma.pos - 1) ; 
delete(Iine,1.comma.pos) ; 

END 

ELSE 

BEGIN 

token :■ line ; 
line :* ’ * ; 

END ; 

IF token « 

THEN token := ; 

strip.traiIing.bIanks(token) ; 

END ; 

END ; (* scan *) 

PROCEDURE buiId.a.row ; 

(* Builds an example row. Symbolic and numerical attributes are handled 
differently. Input lines are read one token at a time and storage is 
allocated for the new token. The attrib.list is examined to see if 
the new value appears on the list of values for that attribute. If it 
does not, the value is added to the list. Symbolic values are added 
to the end of the list of values for the attribute, numerical values are 
stored in order. Once the new row is constructed it is appended 
to the example set. *) 

VAR 

at.I 1st,row.I 1st,token.ptr : node.ptr ; 

PROCEDURE Iength.error ; t 

(* Signal an error, probably a missing value. The row in question 
will not be included in the example set, but the attribute list 
may be damaged, so don’t trust results after and error. *) 

BEGIN 
write In ; 

wrIteIn(’MissIng attribute in row:*) ; 
print.Ilst(row.list) ; 
writeIn ; 
write In ; 
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wait ; 

END ; (* length_error *) 

PROCEDURE add_value ; 

(* Add a new value to the attribue list. The variable attrib_llst keeps 
track of the current column as the row is scanned. If token was 
found to already be on the attrib_list, head(attrlb_l1st) is appended 

to at_I 1st. If the token is a new value, it is added to the list at the 

head of attrib_llst, and then head(attrlb_list) is appended to at_list. 
After reading the entire row from the file, attrib.list Is set to 
point to at_I 1st. This way attrib_list is reconstructed for each 
row. *) 

PROCEDURE Insert_number ; 

(* Insert a number into the attribute list. The list of values 

for numerical attributes is maintained in order. This is done by 
comparing the value of the token against the other items on the 
list. As the comparison is done, the values are copied to new_Jist. 
When a value is found that is greater than the token value or the 
end of the list is reached, the token is appened to new_list and 
then the reaming values on the old list are appended to new_llst. 
Finally new_list is appended to at_list. All of this appending 
produces lots of garbage. *) 

VAR 

new_list,p : node_ptr ; 
r : real ; 

inserted : boolean ; 

PROCEDURE bu1 Id_new_l1st ; 

(* This routine does the actual Insetion described above. *) 

BEGIN 

WHILE (p <> NIL) AND (NOT inserted) DO 
BEGIN 

IF abs(r - num_vaI(head(p))) < limit 
THEN 
BEGIN 

inserted :« true ; 

new_list :« append_list(new_list,p) ; 

END 

ELSE IF r > num_vaI(head(p)) 

THEN 

BEGIN 

new_list :* append_list(new_l1st,cons(head(p),NIL)) ; 
p :« tail(p) ; 

END 

ELSE 

BEGIN 

new_list := append_list(new_list,append_list( 

cons(token_ptr,NIL),p)) ; 

inserted :* true ; 

END ; 

END ; 

END ; (* buiId_new_list *) 

BEGIN 

r := num_vaI(token_ptr) ; 
inserted := false ; 

new_list :* cons(head(head(attrib_list)).NIL) ; 
p := taiI(head(attrib_list)) ; 
buiId_new_list ; 

IF (p = NIL) AND (NOT inserted) 

THEN new_list := append_list(new_list,cons(token_ptr,NIL)) ; 
at_list := append_list(at_J ist,cons(new_list.NIL)) ; 

END ; (* insert_number *) 

BEGIN 

IF tag_value(token_ptr) = number 
THEN insert_number 

ELSE at_list :* append..! ist(at_l ist, 

cons(append_list(head(attrib_list), 

cons(token_ptr,NIL)), 

NIL)) ; 

END ; (* add_value *) 

BEGIN 

saved_list :« cons(examp Ies,attrib_list) ; 
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test.memory ; 

at_Ii81 NIL ; 

row.list :* NIL ; 


scan ; 

WHILE token o'* DO 


BEG IN 

IF pos(*:NUMBER*,toupper(string.vaI(head(head(attrib.list))))) > 
THEN token.ptr :* a I Ioc_num(toreaI(token)) 

ELSE token_ptr :» a I Ioc.str(token) ; 

IF (NOT on. Iist(token,head(attrib.list))) AND (token <> '*') 

THEN add.value , . ti NX 

ELSE at.list := append.list(at_list,cons(head(attrib.list),NIL)) 
row.list := append.list(row_list,cons(token.ptr.NIL)) ; 

a11rib_list : b tail(attrib_Iist) ; 

scan ; 


0 


END ; 

a11rib_list := at.list ; 

IF list_Iength(row.list) = no.of.cols 

THEN examples := append.list(examp Ies,cons(row_list,NIL)) 
ELSE length.error ; 

END ; (* buiId.a.row *) 


PROCEDURE buiId.attrib_list ; 

(* constructs the initial attrib.list from the first row in the file. 
Initially the attrib.list is simply a list of the attribute names, 
bu1 Id.a.row adds the values to it. This routine also counts the 
number of columns (attributes) in the table. *) 


BEGIN 

attrib.list :« NIL ; 
no.of.cols :* 0 ; 


scan ; 

WHILE token <> 
BEGIN 

attrib.list 


” DO 


append Iist(ottrib_list,cons(cons(aIloc_str(token).NIL), 

NIL)) ; 


no.of.cols := no.of.cols + 1 ; 
scan ; 


END ; 

END ; (* build_attrib_list *) 


BEGIN 

examples :■ NIL ; 
line :« ; 

read_from_fiIe(examp Ie_f1le) ; 

IF line <> eof_mark 
THEN buiId_attrib_l1st ; 
read — from_fiIe(exampIe_fiIe) ; 

WHILE line <> eof_mark DO 
BEGIN 

build_a_row ; 

read_from_fI Ie(examp Ie_file) ; 

END ; 

END ; (* buiI datable *) 

OVERLAY FUNCTION classify_it : node.ptr ; 

(* is an overlay function which calls classify. We do it this way to avoid 
swapping due to recursion. *) 

FUNCTION classify(example_list.chosen.Iist : node.ptr) : node.ptr ; 

(* This is the main processing routine of the program. It is passed two 
lists, a list of rows, example.list and a list of attributes already 
chosen. The second list is simply for convenience. That way we don't 
have to calculate the entropy for attribute which can no longer 
contribute to splitting example.set. classify returns a pointer to the 
classification tree built from the example.set. 

If the example list passed to it contains only a single class value, 
classify returns the class.name (attribute name of the first column) and 
the class value. 

Variables: . 

split.elem - the column (attribute number) to split on 
classTfy.list - a temporary list to hold the tree 

spllt.value - for numerical attributes. It contains the value which 
produces the best numerical split. 

classify prints a dot on the screen each time it is entered to show you 
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that the program really hasn't died. *) 

VAR ' 

spI It_eIem : counter ; 
class!fy_list : node_ptr ; 
spIlt_vaIue : reaI ; 

PROCEDURE find_split(VAR split_elem : counter ; VAR min_spIit_vaIue : real) ; 
(* finds the best attribute to split on. It returns the column number on 
which to split and for numerical attribute, the value which produces the 
best split. For each active attribute it constructs a class list the 
class_list has the following format: 

( (attribute value #1 (classl count) (class2 count) _) 

(attribute value #2 (closel count) (closs2 count) _) .) 

The counts ore the number of times each class appears In a row with 
a particular value of the attribute. This list is used to calculate 
the entropy of the attribute. *) 

VAR 

i : counter ; 
attrlb : node_ptr ; 
ent,mln_entropy,spllt_value : real ; 

FUNCTION entropy(I 1st : node_ptr ; cases : counter) : real ; 

(* list is a class list, coses is the number of examples under 

consideration. This routine calculates the entropy H(C|A) from the class 
list. *) 

VAR 

sum,suml,sum2,r : real ; 
p : node_ptr ; 

FUNCTION Iog2(x : real) : real ; 

BEGIN 

IF abs(x) < limit 
THEN Iog2 :« 0.0 
ELSE log2 ln(x) / In2 ; 

END ; (* log2 *) 

BEGIN 

sum :■ 0.0 ; 

WHILE Iist <> NIL DO 
BEGIN 

suml :■ 0.0 ; 
sum2 0.0 ; 
p tail(head(list)) ; 

WHILE p <> NIL DO 
BEGIN 

r num_val(head(talI(head(p)))) ; 
suml :« suml + r * log2(r) ; 
sum2 :■ sum2 + r ; 
p :« tail(p) ; 

END ; 

sum :■ sum + (sum2 * log2(sum2)) - suml : 
list tail(list) ; 

END ; 

entropy := sum / cases ; 

END ; (* entropy *) 

PROCEDURE numeric_entropy(elem.no : counter ; 

VAR num_entropy,num_spIit_value : real) ; 

Find the best split for a numeric attribute. elem_no is the column we 
are working on. num.entropy is the best entropy for this attribute 
and num_spIit_vaIue is the split which gives that value. In 
addition to the class list, this routine produces an ordered list 
of the values for this attribute, called num_list. This list is 
used in making the splits. Each split is half way between successive 
values on the num_li$t. The entropy is calculated for each split. *) 

VAR 

class_l1st,sp,num_list : node_ptr ; 
sp_vaI,num_ent : real ; 
total_cases : counter ; 

PROCEDURE make_num_list ; 

(* constructs num_list. This is essentially the same routine as 
insert_number in build_table *) 

VAR 

new_.l ist,p,q : node_ptr ; 
r : real ; 

inserted : boolean ; 
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PROCEDURE add_to_new__l ist ; 

BEGIN 

WHILE (p <> NIL) AND (NOT inserted) DO 
BEGIN 

IF abs(r - num_vaI(head(p))) < limit 
THEN 
BEGIN 

inserted := true ; 

new_list :« append_list(new_l?st,p) ; 

END 

ELSE IF r > num_vaI(head(p)) 

THEN 
BEG IN 

new_list := append_list(new_l1st, cons(head(p).NIL)) ; 
p :» taiI(p) ; 

END 

ELSE 

BEGIN / 

new_l i st :* append_l i st (new_l i st,append_l i st ( 

cons(alloc_num(r),NIL),p)) ; 

inserted :* true ; 

END ; 

END ; 

END ; (* add_to_new_list *) 


BEGIN 

test_memory ; 

num_l 1st :*= NIL ; 

q :* examp Ie_l1st ; 

WHILE q <> NIL DO 

BEGIN , , . NNN 

r :* num_vaI(head(eIement(head(q),eIem_no))) ; 
new_list :■ NIL ; 
p :« num_list ; 
inserted :■ false ; 
add_to_new_list ; 

IF Tp 58 NIL) AND (NOT inserted) 

THEN new_list append_l ist(new_list,cons(aI Ioc_num(r),NIL)) ; 
num_list :■ new_list ; 
q :« taiI(q) ; 

END ; 

END ; (* make__num_l ist *) 


PROCEDURE make_numeric_class_list(v : real) ; 

(* builds the class list, v is the value to split on. The class_list 
contoins lists for two ranges < v and >- v. The list has the format: 

( (< v (clossi count} (class2 count) .) 

(>« v (classl count) (class2 count) .)) *) 

VAR 

temp_list,p : node_ptr ; 
v str : string80 ; 

BEGIN 

str(v,v_str) ; 

temp_list :■ NIL ; 

p taiI(head(attrib_list)) ; 

WHILE p <> NIL DO 

begin , , x 

temp.list append_list(temp_list,cons(cons(head(p). 

cons(a Iloc_num(0.0),NIL)),NIL)) 

p :* tail(p) ; 

class'list :« cons(cons(aIloc_str(concat(’< ’,v_str)),temp I ist), 
cons(cons(a Iloc_str(concat(*>- *,v_str)), 
copy_list(temp_list)),NIL)) ; 

END ; (* make_numeric_cIass_list *) 

PROCEDURE count_numer1c_cI asses(v : real ; elem_no : counter) ; 

(* count the classes for each range. It reads the example list, extracts 
the value for the attribute, searches the class list and increments 
the appropriate class value In the list, v is the split value. *) 

VAR 

px,py : node_ptr ; 

PROCEDURE numeric_lncrement(list : node_ptr ; attr_v,atv : string80) ; 

(* search list (class_list) and compare attr_v to v, the split_value. 
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atv is the class_value. Once we find the sub-list with the proper 
range we search its tail for atv to increment the class count. *) 

PROCEDURE do_Jncrement(v_list : node_ptr) ; 

VAR 

p,q : node_ptr ; 

BEGIN 

q :* tail(v_list) ; 

WHILE q <> NIL DO 
IF strIng_vaI(head(head(q))) ■ atv 
THEN 
BEGIN 

p :■ head(taiI(head(q))) ; 

IF tag_value(p) ■ number 
THEN p*\num_data p*.num_data + 1.0 ; 
total_cases := total_cases + 1 ; 
q NIL ; 

END 

ELSE q tail(q) ; 

END ; (* do_lncrement *) 

BEGIN 

IF toreaI(attr_v) < v 
THEN do_Increment ( headfIist)) 

ELSE do_lncrement(head(tai 1(1ist))) ; 

END ; (* numeric_lncrement *) 

BEGIN 

total_cases :■ 0 ; 
px :* examp Ie_l1st ; 

WHILE px <> NIL DO 
BEGIN 

py :■ head(px) ; 

numerfc_increment(class_list,string_vaI(head(eIement(py,eI em.no))), 
string_val(head(py))) ; 
px :« tail(px) ; 

END ; 

END ; (* count_numerfc_cI asses *) 

BEGIN 

num_entropy :* 1.0E+37 ; 

make_num_l1st ; 

sp :■ tail(num_l1st) ; 

saved_l!st :* cons(num.list,saved_list) ; 

WHILE sp <> NIL DO 
BEGIN 

test_memory ; 

sp_val :« num_val(head(num_list)) 

+ ((num_vaI(head(sp)) - num_vaI(head(num_list))) / 2.0) ; 
make_numeric_cIass_lIst(sp_val) ; 
count_numeric_cI asses(sp — vaI,elem_no) ; 
num_ent := entropy(cIass_list,totaIncases) ; 

IF num_ent < num^entropy 
THEN 
BEGIN 

num_entropy := num_ent ; 
num_split_value :« sp val ; 

END ; 

num_l 1st :*= sp ; 
sp := taiI(sp) ; 

END ; 

saved_Mst := tai I (saved_l ist) ; 

END ; (* numeric_entropy *) 

PROCEDURE symbol_entropy(val_list : node_ptr ; elem — no : counter ; 

VAR sym_ent,sym_split_val : real) ; 

(* Find the entropy for a symbolic attribute, val.list is the list 
of possible values for this attribute from the attrib_list. 
elem_no is the column number, sym_ent is the entropy for this attribute 
sym_split_value is always 0. This routine constructs a class list 
as described above and counts the classes for each value of the 
attribute as in the numeric case, only there is no range splitting. 
Symbolic attributes can result in mult-way partitions of the 

examp Ie_Iist, numerical attributes always produce binary splits 
VAR Jr 

class_Mst : node_ptr ; 
total_cases : counter ; 
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PROCEDURE make_class_list(a_I 1st : node.ptr) ; 

(* builds the initial class list. See above comments for format. *) 
VAR 


temp_list,p : node_ptr ; 

BEGIN 

WHILE a_list <> NIL DO 
BEGIN 

temp_list := cons(head(a_list),NIL) ; 
p := taiI(head(attrib_list)) ; 

WHILE p <> NIL DO 


BEGIN 
temp_list 


append_list(temp_l 


ist.cons(cons(head(p), 

cons(alloc_num(0.0).NIL)).NIL)) 


p := taiI(p) ; 

END ; / 

class_Mst := append_list(cIass_list,cons(temp_list,NIL)) ; 
a_list :* taiI(a_list) ; 

END : 

END ; (* make_class.J ist *) 


PROCEDURE count_c I asses (el em_.no : counter) ; 

(* traverses the example^list and counts class values. *) 

VAR 

px.py : node_ptr ; 

PROCEDURE increment(Iist : node_ptr ; attr.v : string80) ; 

(* search list (class_list) and compare attr to the head of each sub-list, 
v is the class_value. Once we find the sub-list with the proper 
range we search its tail for v to increment the class count. *) 

VAR 

p.q : node_.pt r ; 

BEGIN 

WHILE list <> NIL DO 
IF str ing__val(head(head(I 1st))) - attr 
THEN 
BEGIN 

q :« taiI(head(Iist)) ; 

WHILE q <> NIL DO 
IF string_val(head(head(q))) ■ v 
THEN 
BEGIN 

p head(taiI(head(q))) ; 

IF tag — value(p) ■ number 
THEN p~.num_data :■ p A .num_data + 1.0 ; 
total_cases :* total — cases + 1 ; 
list NIL ; 

q NIL ; 

END 

ELSE q taiI(q) ; 

END 

ELSE Iist taiI(Iist) ; 

END ; (* increment *) 


BEGIN 


total_cases :■ 0 ; 
px := examp Ie_list ; 
WHILE px <> NIL DO 
BEGIN 


py := head(px) ; 

increment^Iass_list.string_vaI(head(eIement(py.eIem_no))), 
string_val(head(py))) ; 
px :■ tail(px) ; 

END ; 

END ; (* count_cI asses *) 


BEGIN 

cIass_list :* NIL ; 
make_cIass_l i st (va !_l i st ) ; 
count_cIasses(eIem_no) ; 

sym.ent entropy(cIass_list,total_cases) ; 
sym_spI 1 t_va I :■ 0.0 
END ; (* symbol_entropy *) 

BEGIN 

min_entropy :■ 1.0E+37 ; 
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FOR I :■ 2 TO no of cols DO 
BEGIN 

test_memory ; 

attrib :« headfeIement(attrib list,!)) ; 

V- on -'* *t(str ing_vaI (head(attr lb)),chosen_l ist) 

BEGIN 

I Tu?M 8 ^ :NU ^ BER ’ ,toup ^ r ( 8trin 9- vol (head(attrib)))) > 0 
THEN numeric_entropy(I, ent,spIit value) 

ELSE symbol_entropy(taiI(ottrlb)7l.ent.spI It_volue) ; 

IF ent < min_entropy ' 

THEN 

BEGIN 

mIn_ent ropy ent ; 

splIt_eIem := i ; 

mln_splIt_value :■ split_value ; 

END ; 

END ; 

END ; 

END ; (* f1nd_split *) 

FUNeTION spllt(elem no : counter ; spllt.val : real) : node ptr ; 

(* This routine sp its the exomple_list into sets which contain a single 

sd it val^s thi'« ®?J r,b “ te - elem - no is the column on which to sp?it. 

Y? S the sp,lt value for numerical attributes, 
split_ltem points to the attribute’s entry In the attribute list. 

' S th / ^ ee Which is ' eturned b y split. Its format Is* 
(attribute.name (valuel cI ass Ify(par111Ion with attribute - valuel) 

(vaIue2 cI ass Ify(par111ion with attribute = value2) 

. ) *) 

VAR 

sp I 11_I I st, sp I 1t_11em, new__chosen : node_ptr ; 

PROCEDURE numerIc_spIit ; 

(* Splitting on a numerical attribute splits the examples into 
two groups, those with values < splft.value and those with 
values >- splI Rvalue. new_list1 and new_list2 are the example 
sets or the two categories. It returns a split_list as follows: 

(attrIbute_name (*< spllt.vol* 

cI ass Ify(aI I examples with attribute value < split val) 
(’>- split_val• y 

class i f y (a I I examples with attribute value >- split val)) 
Notice all the lists placed on the saved.list. These are the items ” U 

JSllection 8 !)' " Sh ° U,d ° ny ° f the CQ,|S t0 classif y invoke garbage 

VAR 

new_lIs11,new_list2.q,valu : node_ptr ; 
split_str : string80 ; 

BEGIN 

str(spIit_val,split_str) ; 

valu := cons(alIoc_str(concat(’< *,spIit_str)), 

cons(alloc_str(concat(’>= ’.splitistr)),NIL)) ; 
q := examp Ie_list ; " 

new_listl :« NIL ; 
new_lIst2 :« NIL ; 

WHILE q <> NIL DO 
BEGIN 

IF num_va I (head(e I ement (head(q), e I em_.no))) < split.val 
THEN new.listl := append_list(new.list1, cons(head(q),NIL)) 

ELSE new Iist2 :« append_list(new_list2,cons(head(q),NIL)) • 
q :* tai I (q) ; » // » 

END ; 

cons(split_list,cons(valu,cons(new Iist2,saved |ist}}} • 

append_l ist(spl it_I ist, ~ n> ' 

cons(cons(head(vaI u), 

cons(classify(new_list1,chosen_list).NIL)).NIL)) : 

cons(spI 1 1_I ist,taiI(saved_list)) ; 

append_list(spI It_list, 

cons(cons(head(taiI(valu)), 
cons(cl assify(new_list2,chc 
taiI(taiI(taiI(saved_list))) ; 


saved_list 
spIit_list 


saved_list 
split_list 


saved_list 


,chosen_list).NIL)),NIL)) 


END ; (* numeric_spIit *) 

PROCEDURE symbol_split ; 

( * th ?. s P Mt ! or symbolic attributes. For each value of the 

+ h sear8h * s the example list for matches and attaches 
examples with a match to new_exampIe_list. If it finds any matches 
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it appends the value and the result of classifying the new.exampIe.list 
to spIit.iist. This is a very inefficient way of doing this. It 
would be better to sort the example.list using column elem.no as 
a key. *) 

VAR 

vaIu,q,new.exampIe.l1st : node.ptr ; 

BEGIN 

valu :* tail(split_item) ; 

WHILE valu <> NIL DO 
BEGIN 

q := examp Ie.list ; 
new.exampIe.list :» NIL ; 

WHILE q <> NIL DO 
BEGIN 

IF string.val(head(valu)) = string.vaI(head(eIement(head(q),eI em.no))) 
THEN new.example.list := append.Iist(new.exampIe_Iist,cons(head(q),NIL)) 
q := taiI(q) ; 

END ; 

IF new.exampIe.list <> NIL 
THEN 


BEGIN 
saved.list 
split.Iist 


:* cons(split.Iist,saved.list) ; 

:* append_Iist(split_Iist, 

cons(cons(head(vaIu), 

cons(cI assify(new.exampIe.list,new.chosen),NIL)), 
NIL}) ; 

:* tail(saved.list) ; 


saved.list 
END ; 

valu := tail(vaIu) ; 

END ; 

END ; (* symbol.split *) 

BEGIN 

split.item :■ head(eIement(attrib.list,eIem.no)) ; 
new chosen :* cons(head(spIit.itern},chosen.Iist) ; 
split.list :» cons(head(spIit.item),NIL) ; 

IF pos(*:NUMBER',toupper(string.vaI(head($pI 1t.item)))) > 0 
THEN numeric.split 
ELSE symbol.split ; 
split :« split.list ; 

END ; (* split *) 

FUNCTION slngle.class : boolean ; 

(* returns true if the example.list contains only a single class value. *) 
VAR 

first.val : string80 ; 

p : node.ptr ; 

more than.one : boolean ; 

BEGIN / ... 

first.val :« string.vaI(head(head(exampIe.list))) ; 
more.than.one :* false ; 
p :® taiI(exampIe.list) ; 

WHILE (p <> NIL) AND (NOT more.than.one) DO 
IF string.vaI(head(head(p))) <> first.val 
THEN more.than.one :■ true 
ELSE p tail(p) ; 
single.class := NOT more.than.one ; 

END ; (* single.class *) 

BEGIN 

write('.’) ; 
spIit.eIem := 0 ; 

saved.list :■ cons(chosen.list,cons(exampIe.list,saved.list)) ; 

IF NOT single.class 

THEN find.split(spIit.elem.split.value) ; 

IF spl1t.eIem « 0 

THEN classify.list cons(head(head(attrib.list)), „ 

cons(cons(head(head(examp Ie.list)),NIL),NIL)) 
ELSE cI assify.list spIit(spIit.eIem,spIit.vaIue) ; 
saved.list :■ append.Iist(tail(tail(saved.list)),cons(classify.list.NIL)) ; 
classify :* cI assify.list ; 

END ; (* classify *) 


BEGIN 

classify.it :* cI assify(exampIes,NIL) ; 
END ; (* classify.lt *) 


[continued) 
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OVERLAY PROCEDURE prInt.ru Ie.list(Iist : node ptr) ; 

(* This routine transforms the tree into a set of IF/THEN statements and 
writes them to a file. It produces a knowledge base for MicroExpert [cl 
if you want to produces rules for another shell, this routine will 
have to be modified. *) 

VAR 

rule.count : counter ; 
ruIe.fiIe : text.file ; 
file.nome : string80 ; 
used.attrfbs : node.ptr ; 


PROCEDURE prI nt.ru Ie(tree,ruIe.list : node.ptr) ; 

(* Do o depth first troversol of tree. On entry ruIe_lIst contains a 
list of attribute value pairs. When tree is finally NIL, i.e. a 
terminal node of the tree has been encountered, the rule list is 
printed. If entered with a non-NIL tree, the routine creates a new 
attribute value pair, attaches it to rule.list and explores further 
down the tree. It also attaches the attribute names to used.attribs 
so that they can be used to generate prompts. *1 
VAR ' 

p : node.ptr ; 


PROCEDURE print_the.ru Ie(Iist : node.ptr) ; 

(* Prints the rule.Iist, with rules formatted for MicroExpert. *) 
VAR 

s : string80 ; 

PROCEDURE write.compare ; 

VAR 

comp.str : string[2] ; 

FUNCTION quote(w : string80) : string80 : 

BEGIN 

quote := •*•• + w + •••• ; 

END ; (* quote *) 


BEGIN 

comp_str :« '* ; 
WHILE s[1] <>' * DO 
BEGIN 


comp.str := comp_str + s[ 11 ; 
deIete(s,1,1) ; 

END ; 

strip.leading.blanks(s) ; 
str ip.traiIing.bIanks(s) ; 

writeln(rule.file,'function compare(',attrib.vaIue(head(head (list))) 
, »quote(comp_str),',',quote(s),')') ; 

END ; (* write.compare *) 


BEGIN 

writeIn(ruIe.fiIe,ruIe.count) ; 
rule.count :* ruIe.count + 1 ; 
wr ite(rule_file,'If ') ; 

WHILE Iist O NIL DO 
BEGIN 

s :** str ing.val (head(tai I (head (I ist)))) : 

IF s[1] IN ['<','>'] ' 

THEN write.compare 

ELSE writeln(rule_file.attrib.vaIue(head(head(Iist))),' is 
list := tall(llst) ; 

IF Iist O NIL 
THEN 

IF tai1(1ist) * NIL 
THEN wrItefrule.file,'then ') 

ELSE write(rule_file,'and ') ; 

END ; 

writeln(rule_f Me,'.') ; 
writeIn(ruIe.file) ; 

END ; (* print.the.ru Ie *) 


.s) ; 


BEGIN 

IF tree = NIL 

THEN print_the_rule(rule list) 

ELSE 

BEGIN 

IF head(tree) o head(head(attrib.list)) 
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IF NOT on_list(string_val(head(tree)),used_attribs) 

THEN used_attribs :* cons(head(tree),used_attribs) ; 
p :« tail(tree) ; 

WHILE p <> NIL DO 
BEGIN 

print_ruIe(head(taiI(head(p))), 

append_lIst(rule_l1st,cons(cons(head(tree) , 

cons(head(head(p)),NIL)), 
NIL))) ; 

p :* taiI(p) ; 

END ; 

END ; 

END ; (* print_rule *) 

PROCEDURE print_prompts ; 

(* This routine traverses the attribute list and writes a prompt for 
each attribute on the list. MicroExpert does not automatically 
generate prompts, so this is necessary. The format 
of the questions may seem dumb. For a working knowledge base, you 
will want to edit the prompts and add translations. *) 

VAR 

q : node_ptr ; 

BEGIN 

q :« used_attribs ; 

WHILE q <> NIL DO 
BEGIN 

writeIn(ruIe_fiIe) ; 

IF pos(*:NUMBER’,toupper(string_vaI(head(q)))) > 0 
THEN writeInfruIe_file,’Numeric prompt *,attrib_value(head(q))) 

ELSE writeIn(ruIe_f1 Ie,’Prompt ',attrib_vaIue(head(q))) ; 
writeIn(ruIe_fiIe,*What is the value of *,attrib_vaIue(head(q)),' ?') ; 
writeIn(ruIe_fiIe,*.*) ; 
q := taiI(q) ; 

END ; 

END ; (* prlnt_prompts *) 

BEGIN 
wr i teIn ; 

write(’Output the rules to what file (Press <ENTER> for screen.) ? *) ; 

read In(fiIe_name) ; 

strip_leading_bIanks(fiIe_name) ; 

IF filename - •• 

THEN file^name :* ’con:’ ; 
assign(ruIe_fiIe,fI Ie_name) ; 
rewrite(ruIe_fiIe) ; 
wr iteIn(ruIe_fiIe) ; 
rule_count :« 1 ; 
used_attribs NIL ; 
print_ruIe(Iist,NIL) ; 
print_prompts ; 

IF is_consoIe(ruIe_fI Ie) 

THEN wait ; 
close(ruIe_flie) ; 

END ; (* prlnt_ruIe_list *) 


OVERLAY PROCEDURE print_tree(Iist : node.ptr) ; 

(* Print the tree. This Is really just a pretty print routine, which 
indents each sub_list. *) 

VAR 

indent_Jevel : counter ; 
tree_fiIe : text_flie ; 
file_name : string80 ; 

PROCEDURE print_the_tree(tree : node_ptr ; VAR indent : counter) ; 

VAR 

p : node_ptr ; 

BEGIN 

IF tree <> NIL 
THEN 

CASE tree".tag OF 
number, 

symbol : BEGIN 

write(tree_fIle.attrib_vaIue(tree),’ ') ; 

Indent indent + Iength(attrib_vaIue(tree)) + 1 ; 


[continued) 
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END ; 

cons_node : BEGIN 

write(tree_file,•(») ; 

Indent :■ indent + 1 ; 

P r lnt.the.tr ee(head(tree),indent) ; 
p taiI(tree) ; 

WHILE p <> NIL DO 
BEGIN 

prlnt_the.tree(head(p),indent) ; 

IF I 1st.length(p) > 1 
THEN 
BEGIN 

writeIn(tree.flie) ; 

write(tree.flie,* * : indent) ; 

END ; ' 

P tail(p) ; 

END ; 

indent:- indent - length(attrib_value(head(tree))) 
write(tree_flie,') *) ; 1,1 

END ; 

END ; 

END ; (* print_the_tree *) 

BEGIN 
writeln ; 

wri !? ( /?^ put th ! tree t0 what file ( Pr «ss <ENTER> for screen.) ? •) 
read In(fiIe.name) ; ' ' 

strip.leadlng.blanks(fiIe.name) ; 

IF fiIe.name ■ * 9 

THEN fI Ie_name :* 'con:' ; 

assign(tree.fI le.fi Ie.name) ; 
rewrite(tree.file) ; 
wrlteln(tree_fIle) ; 
indent.level :» 0 ; 
prlnt_the.tree(list,indent level) ; 
wr1teIn(tree.flie) ; 
wrIteIn(tree.fI Ie) ; 

IF is_console(tree.fIle) 

THEN wait ; 
close(tree.file) ; 

END ; (* print.tree *) 

OVERLAY FUNCTION got.file : boolean ; 

(* asks for an example file name and tries to open it. If it can't 
VAR° Pen the fMe ’ ** complains and asks for a new file *) 

examp Ie.name : string80 ; 

BEGIN 
writeln ; 

wr i te('Examp Ie File (Press <ENTER> to quit.) : ') ; 
read In(exampIe.name) ; 

IF examp Ie.name * " 

THEN got.file :* false 
ELSE 
BEGIN 

IF pos( '. ',examp Ie.name) = 0 

THEN examp Ie.name :» concat(examp Ie.name,'.EX') ; 

IF open(examp le.fi Ie,examp Ie.name) 

THEN got.file :* true 
ELSE 
BEGIN 
writeln ; 

write In(toupper(examp Ie.name),' could not be found ') • 
writeln ; ' ' 

got.file := got.file ; 

END ; 

END ; 

END ; (* got.fI Ie *) 


BEGIN 

free :« NIL ; 
initial.heap := HeapPtr ; 
total.free :■ 0.0 ; 
clrscr ; 

WHILE got.file DO 
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BEGIN 

buiId_tabIe ; 
cIose(exampIe_fiIe) ; 

IF NOT confIicts(examp Ies) 

THEN 

BEGIN 

saved_list :* cons(attrib_list,examples) ; 
expand(exampIes,examp Ies) ; 
write In ; 

saved_list := cons(attrib_list,examp Ies) ; 

c_list := cI assify_it ; 

saved_list := cons(c_list,attrib_list) ; 

wr iteIn ; 

test_memory ; 

print_tree(c_list) ; 

wr 1 teIn ; 

test_memory ; 

writeln ; 

pr int_.ru I e_J ist(c_l ist) ; 
clrscr ; 

END ; 

END ; 

END. 


MARVIN.P 

"Machine Learning," by Angelos T. Kolokouris, November 1986, page 225. 


program marvin(input, output, memfile); 

label 0; 

const 

StringSize * 10; 

HashMax = 63; 

MaxVar ■ 63; 

SubstTop = 200; 

SubTraiITop - 200; 

MaxOut ■ 20; 


type 

HashRange = 0..HashMax; 

VarRange ■ 0..MaxVar; 

SubstRange * 0..SubstTop; 

SubTraiI Range ■ 0..SubTraiITop; 

WayOut * -2..MaxOut; 

thingtype - (ATOM, VARIABLE, NUMBER, OBJECT, SEQ, SELECTOR, 
QVAR, CONCEPT, DISJUNCTION, STATEMENT); 

string ■ packed array [1..StringSize] of char; 

message * packed array [1..40] of char; 


pairIist * ~pair; 
value ■ A thing; 
list * *1istcelI; 


th i ng 


record 

case key: thingtyp 
ATOM : 

VARIABLE : 

NUMBER : 

OBJECT : 

SEQ : 

SELECTOR : 

QVAR : 

CONCEPT : 

DISJUNCTION : 


STATEMENT : 


e of 

fpname: string; rep, link: value); 
(offset: VarRange); 

S numvaI: integer); 

varno: -1..MaxVar; plist: pairIist); 
( s: list); 

(obj, prop: value); 

(qval: vaIue); 

(formal: list; defn: value); 

(exvars: list; 
conjunct ion: list; 
alternatives: value); 

(state: WayOut; 

(* LastTrial: boolean; *) 
implicants: list; 


( continued) 
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fname: value; 
args: list); 

end; 

listcell * record hd; value; tls list end; 

pair * record 

prop, val; value; 
next: pairIist 

end; 

Varlnstance * record 

varcelI; value; 
isin; list 

end; 

a Iist = "triple; 

triple * record 

ind: value; 

Usedln: list; 
rest: alist 
end; 


var 

memflie: text; 

ReadMem: boolean; 

name: packed array [1..14] of char; 

NoMoreVars: boolean; 

hashtable: array [HashRange] of value; 

item: array [VarRange] of Varlnstance; 

subst: array [SubstRange] of value; 

subtrail: array [1..SubTraiI Top] of SubstRange; 

nextvar: VarRange; 

yes, no, answer: value; 
memory: a Iist; 

LastSubst: SubTraiI Range; 
trial: value; 
preveg: list; 

base, TopSubst: SubstRange; 

UsedPairs: pairIist; 
gtime: integer; 


{ 

function clock: integer; 
beg i n 

clock:* runtime; 

end; 

\ 


(* DEC-20 uses different name *) 


procedure error(msgno: integer); forward; 

function newvar: value; 
beg i n 

(* writeIn(*Creating new variable *, nextvar:1); *) 
if NoMoreVars then error(l); 
newvar:» item[nextvar].varceI I; 
nextvar:* nextvar + 1; 

if nextvar » MaxVar then NoMoreVars:* true 
end (* newvar *); 

function newobj: value; 
var 

v: value; 
begin 

new(v); 
with v" do 
beg i n 

key:* OBJECT; 
varno:* -1; 
piist:* nil 

end; 

newobj:* v 
end (* newobj *); 

function newq: value; 
var 

q: value; 
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beg i n 

new(q, QVAR); 
with q^ do 
beg I n 

key:- QVAR; 
qvaInil 


end; 

newq:« q 
end (* newq *); 


(* 

********************************************************************************* 
** Output Routines 

***************** *************************************************************** 
*) 

procedure prllst(l: list); forward; 

procedure prin(p: value); 

procedure prword(s: value); 
var 

i: 1..StringSize; 
beg i n 

i :* 1; 

with s~ do while (i <> StringSize) and (pname[i] <> * *) do 
beg i n 

write(pname[i]); i:* i + 1 
end 

end (* prword *); 

procedure prpair(p; pairlist); 
begin 

whiIe p <> niI do 
beg i n 

with p* do 
beg i n 

prword(prop); 
wr i te(*: *); 
pr in(vaI); 

if next <> nil then write(’; *) 

end; 

p:« p^.next 

end; 

wr1te(•>*) 

end (* prpair *); 


begin (* prin *) 

if p « nil then wrlteC*.*) 
else case p^.key of 
ATOM 

VARIABLE 
NUMBER 
OBJECT 
SEQ 

SELECTOR 
QVAR 


end 

end (★ prin *); 


prword(p); 

wr i te( 'X*, p*.offset:1); 
write(p A .numvaI: 1); 
begin write('<*); prpair 
beg In wr i te(*(*); prIist 
begin prin(p^.obj); writ 
lf p^.qvaI <> niI then p 
else wr1te('* *); 


(p'.pi 
(p~.s) 
«(’.’) 
rin(p“ 


ist) end; 

; write(’)*) end; 

; prword(p^.prop) end; 
.qvaI) 


procedure print(p: value); 
beg i n 

prin(p); writeln 

end; 


procedure prlist(* I: list *); 
beg i n 

while I <> nI I do 
beg i n 

pr ln(I*.hd); 

I r.t I ; 

If I <> nil then wrlte(', ') 

end 

end (* prIist *); 


(continued} 
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procedure tabs(n: integer); 
beg i n 

for n:« n downto 1 do write(* ’) 

end; 


procedure prexpr1(expr: value; n: integer); 
var 

p: list; 
beg i n 

if expr <> nil then with expr* do case key of 
CONCEPT ; begin 

tabs(n); 
wr 1 te(*[*); 
prIist(formal); 
writelnf*: ’); 
prexpr1(defn, n+1); 
tabs(n); wr i teIn(’]’); 

end; 

DISJUNCTION : begin 

If exvars <> niI then 
beg i n 

tabs(n); 
wr 1 te(*[E *); 
prIist(exvars); 
writeln(*:•); 
n:= n+1; 

end; 

p:= conjunction; 
while p <> nil do 
beg i n 

prexpr1(p*.hd, n); 
p:* p*.tl 

end; 

i f exvars <> nlI then 
beg i n 

n n - 1; 

tabs(n); writeIn(*]*); 

end; 

if alternatives <> nil then 
beg i n 

wr1teIn(’OR'); 
prexpr1(alternatives, n) 

end 

end; 

STATEMENT : begin 

tabs(n); 

if fname = eq then 
beg i n 

prin(args*.hd); 
wr i te(’ * *); 
print(args*.11 *.hd) 
end 

e I se 


end 

end (* prexprl *); 


beg i n 

pr in(fname); 
wr i te(*(’); 
pr I ist(args); 
wr i teIn(')*); 

end 

end 


procedure prexpr(expr: value); 
beg i n 

prexpr1(expr, 0); 
writeIn; 

end; 


procedure prmem; 
var 

m: a Iist; 
beg i n 

m:= memory; 

whiIe m <> niI do 

beg i n 
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prexpr(m".ind); 
tabs(1); 

prIist(m".UsedIn); 
wr iteIn; 
m:- m".rest 

end 

end (* prmem *); 

procedure prconj(p: list); 
beg i n 

whiIe p <> niI do 
beg i n 

if p".hd".state <> 0 then 

write(p".hd".state:3, ’>'); 
prexpr1(p~.hd, 1); 
p:« p".tl 

end 

end (* prcon *); 

procedure dumpsubst(i: SubstRange); 
begin 

wr iteIn(’Substitut ions:'); 
for i:« i downto 0 do 
beg i n 

if substfi] = nil then writeIn('<>') 
else print(subst[i]); 

if i - nextvar then wr iteIn(’-*); 

end 

end (* dumpsubst *); 

function newpair(pr: value); pairlist; 
var 

p; pairlist; 
beg i n 

if UsedPairs * nil then 
beg i n 

new(p); 

p~.vaI:« newq 

end 

e I se 

beg i n 

p:« UsedPairs; UsedPairs;= p".next; 
if p A .val".key <> QVAR then p^.val:- newq 
else if p*.val".qval <> nil then 
beg i n 

write(’NOT GONE! *); print(p".val".qval); 
goto 0; 

end; 

end; 

p".prop:- pr; 
p".next:- nil; 
newpair:- p 
end (* newpalr *); 

function cons(v: value; I: list); list; 
var 

p; list; 
beg i n 

new(p); 
p~.hd:» v; 

P*.tl;- I; 
cons:- p 
end (* cons *); 

procedure conc(var I: list; v; value); 
var 

II, 12: list; 
begin 

new(II); 

I1".hd:« v; II".tlnil; 
if I - nil then I:* II 
else begin 
12:- I; 

while 12".tl <> nil do 12:- 12".tl; 

12".tl:- II 


[continued) 
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end 

end (* cone *); 

procedure delete(x: value; var I: list); 
var 

found: boolean; 
p, t: list; 
beg I n 

If I <> n11 then 

If r.hd <> x then 
beg I n 

p:- I; found:- false; 
while (p~.tl <> nil) and not found do 
i f p~.tl~.hd - x then 
beg i n 

t:= p*.tI; 

p~.tl:« p~.tr.tl; 

dIspose(t) 

end 

else p:» p~.tI 

end 

else I:= r.tI 
end (* delete *); 

procedure copy(s1: list; var s2: list); 
var 

p: list; 
beg i n 

if si <> nil then 
beg i n 

new(p); s2:- p; 
p~.hd:= s1~.hd; 
si:- s1~.tl; 
while si <> nil do 
beg i n 

new(p~.tI); p:» p~.tI; 
p~.hd:» s1~.hd; 
si:- s1~.tl 

end; 

p~.tI:= nil 

end 

else s2: = nil 
end (* copy *); 

function newcopy(v: value): value; 
var 

p: value; 

function copypairs(l: pairlist): pairlist; 
var 

p: pairlist; 
beg I n 

if I <> niI then 
beg i n 

new(p); 

p~.prop:= l~.prop; 
p~.val:- newcopy(l~.vaI); 
p~.next:» copypairs(l~.next); 
copypairs:- p 

end 

eIse copypairs:» nil 
end (* copypairs *); 

function copyseq(s: list): list; 
var 

p: list; 
beg i n 

if s <> nil then 
beg I n 

new(p); 

p~.hd:« newcopy(s~.hdJ; 
p~.tl:- copyseq(s~.tI); 
copyseq:- p 

end 

eIse copyseq:= niI 
end (* copyseq *); 
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begin (* newcopy *) 

while v^.key - QVAR do v: = v^.qval; 
case v^.key of 
ATOM, 

NUMBER : newcopy:® v; 

OBJECT : begin 

new(p, OBJECT); 
p^.key:= OBJECT; 
p^.plist:® copypairs(v*.pIist); 
newcopy:® p; 

end; 

SEQ : begin 

new(p, SEQ); 
p~.key:» SEQ; 
p~.s:= copyseq(v*.s); 
newcopy:® p 

end; 

end 

end (* newcopy *); 

function member(x: value; y: list): boolean; 
var 

found: boolean; 
begin 

found:® false; 

while (y <> nil) and not found do 
if x ■ y^.hd then found:® true 
eIse y:■ y~.tI; 
member:® found 
end (* member *); 

procedure freeval(var v: value); forward; 

procedure freelist(var I: list); 
var 

p: list; 
beg i n 

while I <> niI do 
beg i n 

freevaI(Ihd); 

p:® I ; I :« r.t I ; 

di spose(p) 

end 

end (* free list *); 


procedure freeval(* var v: value *); 
var 

p: pair I ist; 
beg i n 

(* writeln('FREE’); *) 

if v <> nil then with v* do case key of 


ATOM, 

VARIABLE, 

NUMBER 

: v:® nil; 

OBJECT 

: if piist o nil then 

SEQ 

begin 

p:■ p1 i st; 

while p*.next <> ni1 
p^.next:* UsedPairs; 
UsedPairs:■ p1ist; 
p11st:» nil; 
dispose(v, OBJECT) 
end 

else v:* nil; 

: begin 

SELECTOR 

free 11st(s); 
dispose(v, SEQ) 

end; 

: dispose(v, SELECTOR); 

QVAR 

: begin 

STATEMENT 

freeva1(qva1); 
writeln(’ Ml ’); 
dispose(v, QVAR) 

end; 

: 1 f state > 0 then 


[continued] 
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beg 1 n 


orgs): 


free 1Ist( 


freelist( 

implicants); 


dispose(v 

. STATEMENT) 

end 




(* CONCEPT and DISJUNCTIONS are never freed In the current system *) 

end; 

end (* freeval *); 

procedure freeout(l: list); 
var 

p: list; 
beg I n 

while I <> n11 do 
beg I n 

p:» I ; 

I :- r.t I ; 

dispose(p) 

end 

end (* freeout *); 


(* 

** Input Routines 

t******************************************************************************* 

*) 

function nextch; char; 
beg i n 

if ReadMem then nextch:- memfile^ 
else nextch:- input^ 

end; 

procedure readch(var ch: char); 
beg i n 

If ReadMem then read(memfI Ie, ch) 
else read(Input, ch); 

end; 

procedure advance; 
var 

ch: char; 

begin 

if ReadMem then get(memflle) 
else get(input) 

end; 

function endfile: boolean; 
beg i n 

If ReadMem then endfile:- eof(memfile) 
else endfile:- eof(input) 

end; 

function endline: boolean; 
beg i n 

if ReadMem then endline:- eoIn(memfI Ie) 
else endline:* eoln(input) 

end; 


procedure skipblanks; 
var 

blank: boolean; 
beg i n 

blank:- true; 
while bIank do 

If endfile then blank:- false 

else if endline or (nextch * ' ’) or (nextch - * *) then advance 

else bIank:- fa Ise 

end; 

procedure Iookfor(goaI: char); 
beg i n 

skipbIanks; 

if nextch <> goal then 
beg i n 
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(* wr iteIn(goaI, *: NOT FOUND*); *) 
error(2); 

end; 

advance 

end; 

(* find performs hashtable search for identifiers *) 

function find(var id: string): value; 
var 

p: value; 
h: HashRange; 
found: boolean; 

function hash(var id: string): HashRange; 
var 

acc: integer; 
i: 1..StringSize; 
beg i n 

acc:* 0; 

for i:« 1 to StringSize do acc:* acc + ord(id[i]); 
hash:* acc mod (HashMax + 1) 

end; 

begin (* find *) 

found:* false; h:* hash(id); 

p:* hashtabIe[h]; 

repeat 

if p * nil then 
begin 

new(p, ATOM); 
with p^ do 
beg i n 

pname:* id; key:* ATOM; rep:* nil; 

Iink:* hashtabIe[h]; 

end; 

find:* p; 
hashtabIe[h]:* p; 
found:* true 

end 

else if p^.pname * id then 
begin 

find:* p; 
found:* true 

end 

else p:= p*.I ink 
unti I found 
end (* find *); 

procedure inconcept(var name: value); forward; 

procedure readval(var item: value); forward; 

procedure readnum(var n: value); 
var 

ch: char; 
acc: integer; 
beg i n 

acc:* 0; 

while nextch in [*0*..*9*] do 
begin 

readch(ch); 

acc :* acc * 10 + (ord(ch) - ord(’0’)); 

end; 

new(n, NUMBER); 
with n A do 
beg i n 

key:- NUMBER; 
numvaI:* acc 

end; 

end (* readnum *); 

procedure readword(var w: value); 
var 

i: 0..StringSize; 

( continued ) 
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Id: string; 
ch: char; 
beg I n 

for I:« 1 to StrlngSIze do Id[I]:- 1 '; 

I :■ 0; 

while (nextch In ['A'..'Z', *a*.. # z* # '-•]) do 

If I < StrlngSIze then 
begin 

i:- I + 1; 
readch(ch); 

Id[I]:■ ch; 

end 

else advance; 
w:= flnd(id) 
end (* readword *); 

procedure readllst(var I: list; closer: char); 
beg i n 

(* wrIteIn(’READLIST', closer); *) 
skipbIanks; 

If nextch =* closer then 
beg I n 

advance; 

I:- nil; 

end 

else If nextch In *E’, *(*, ’,*] then 

beg I n 

advance; 
new(l); 

readvaI(Ihd); 

read I Ist(I11, closer) 

end 

else begin 

(* wrIteIn(nextch); *) 
error(3) 

end 

end (* readl1st *); 

procedure readpaIrs(var p: pa IrI 1st); 
begin 

skIpbIanks; 

If nextch ■ *>' then 
beg i n 

advance; 
p:= nil 

end 

else if (nextch = •;’) or (nextch « *<*) then 
beg i n 

advance; 
new(p); 
with p~ do 
beg I n 

skipbIanks; 
readword(prop); 
lookfor(*:'); 
readvaI(vaI); 
readpairs(next) 
end 

end 

else error(4) 
end (* readpairs *); 

procedure readvar(var val: value); 
var 

v: value; 
n: VarRange; 
begin 

(* writeln(’READVAR’); *) 
advance; 

If ReadMem then read(memfiIe, n) 
else read(input, n); 
v:= item[n].varceI I; 
i f nextch - then 
beg I n 

(* writeIn(’SELECTOR'); *) 
advance; 
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new(val, SELECTOR); 
val*.key:* SELECTOR; 
vaI*.obj:* v; 
readvaI(vaI*.prop); 

if vaI*.prop*.key <> ATOM then error(5); 

end 

else va I :* v 
end (* readvar *); 

procedure readval(* var item: value *); 
beg i n 

(* writeln(’READVAL'); *) 
sk ipbIanks; 

if endfile then item:* nil 

else if nextch * then readvar(itern) 

else if nextch in [’A*..*Z*, 'a*..*2*] then readword(itern) 
else if nextch in ['O'..*9'] then readnum(itern) 
else if nextch * *<* then 
begin 

new(item, OBJECT); 
item*.key:* OBJECT; 
itern*.varno:= -1; 
readpairs(item*.plist) 

end 

else if nextch = •(• then 
beg i n 

new(item, SEQ); 
item*.key:* SEQ; 
readlist(item*.s, *)*) 

end 

else error(6} 
end (* readval *); 

procedure readdef; 
var 

n: value; 
beg I n 

readvaI(n); 

i f n <> niI then 

begin 

if n*.key <> ATOM then error(7); 
lookfor(); 
skipbIanks ; 

If nextch » *[* then inconcept(n) 
else readvaI(n*.rep); 

end 

end (* readdef *); 

procedure look; 
beg I n 

reset(memflie); 

while not endfile do readdef; 

end; 

function subset(M, 12: list): boolean; 
begin 

while (II <> nil) and (12 <> nil) do 
beg I n 

if II*.hd = 12*.hd then II:* II*.tl; 

12:- 12*.tl 

end; 

subset:- II * nil 
end (* subset *); 

(* covered finds out If a statement is redundant. 

This is done by seeing if a statement further 
contains the args of the present statement. 

It used to be done by seeing if the implicants 
were a subset. *) 

function covered(s1: value; I: list): boolean; 
var 

c: boolean; 

I: list; 


( continued ) 
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beg I n 

I:- si*.args; c:- false; 

If I <> nfI then 

while (I <> nil) and not c do 

if l^.hd*.state <> 0 then I:■ 
else If subset(I, I^.hd^.args) 
else I :« r.t I ; 

(* if c then writeIn('Covered*); *) 

covered:- c 
end (* covered *); 


*.tl 

then c:- true 


(* 

** Object Generator 

*) 

(* this file contains the object generation routines *) 

function prove(conj, formal, actual, exvars: list): boolean; 

label 1; 

const 

LocalTop - 300; 

ControlTop - 100; 

TraiITop » 200; 


type 

LocalRange - 0..LocalTop; 

ControlNode - 0..ControITop; 

TrailRange « 0..TrailTop; 

ControIRecord - record 

bindings: LocalRange; 
traiIpt : TraiIRange; 
alternatives: value; 
parent : ControlNode; 
cont1nuation: list 

end; 


var 

local: array [LocalRange] of value; 
node: array [0..ControITop] of ControIRecord; 
trail: array [1..TraiITop] of value; 
frame, sp: LocalRange; 
bound, successful: boolean; 

TopNode, ThisNode, LastNode, base: ControlNode; 

tp: TraiIRange; 

start, out: list; 

failure, LastFailure: value; 

StartTime: integer; 

procedure warning(msgno: Integer); forward; 

procedure dump I oca I(sp: LocalRange); 
var 

I: LocalRange; 
beg I n 

writeIn(*- LOCAL STACK -'); 

for !:■ sp - 1 downto 0 do begin write(i, * '); print(I oca I[i]) end; 
writeIn( ’ -««*=*============ • ) ; 

end (* dump I oca I *); 

procedure dumpcontrol; 
var 

i: ControlNode; 
beg i n 

for i:« ThisNode downto 1 do with node[i] do 
begin 

write(i, parent, trailpt, * *); 
prexpr1(continuation^.hd, 0) 

end 

end (* dumpcontrol *); 

procedure show(exvars: list); 
beg I n 

while exvars <> niI do 
beg i n 
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prin(exvars".hd); write(* * '); 
pr Int(local[exvars".hd".offset]); 
exvars:* exvars".tl 

end 

end (* show *); 

procedure addtrail(v: value); 
beg I n 

if tp = TrailTop then warning(l); 
tp:* tp + 1; 

(* writeIn(* TRAIL TOP IS’, tp); *) 
trail[tp]:* v 

end; 

procedure clearq(btp: TrailRange); 
beg i n 

(* writeIn(’CLEARING FROM’, tp, ' to', btp+1); *) 
while tp > btp do 
beg i n 

(* write(’CLEAR*, tp, ' ’); print(traiI[tp]); *) 

trail[tp]".qvaI:= nil; 

(* freeval(traiI[tp]".qval) *) 
tp:« tp - 1 

end 

end (* clearq *); 

procedure SaveEnv(b: LocalRange; t: TrailRange; a: value; 
p: ControlNode; c: list); 

beg i n 

(* writeln(’Saving Environment*, t); *0 
if TopNode * ControlTop then warning(2); 

TopNode:* TopNode + 1; 
with node[TopNode] do 
beg i n 

bindings:* b; 
tralIpt:= t; 
alternatives:* a; 
parent:* p; 
continuation:* c 

end; 

(* writeIn(’SAVED AT', TopNode:3, ’ TRAIL IS’, t:3); *) 
end (* SaveEnv *); 

function unbound(q: value): boolean; 
begin 

if q".key * QVAR then 

unbound:* q".qval * nil 
else unbound:* false 
end (* unbound *); 

function valofq(q: value): value; 
var 

bound: boolean; 
begin 

(* write('VAL OF Q ’); print(q); *) 
bound:* true; 

while (q".key * QVAR) and bound do 

If q".qval * nil then bound:* false 
else q:* q".qvaI; 
valofq:* q 
end (* valofq *); 

function get(ob, property: value): value; 
var 

p, q: pairlist; found: boolean; 
begin 

(*write(’GET ’); prin(ob); write(* '); print(property); *) 
If ob - niI then get:* niI 

else if ob".key in [ATOM, NUMBER] then get:* nil 
else If unbound(ob) then with ob" do 
begin 

qval:* newobj; addtraiI(ob); 
qvaI".pI 1st:* newpair(property); 

(* wrIte(’NEWOBJ: ’); print(ob); *) 
get:* qval".piist".val 


[continued] 
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end 

else begin 

p:= ob A .pl!st; found:- false; 
while (p <> nil) and not found do 

If p^.prop - property then found:- true 
else begin q:« p; p:- p^.next end; 


If found then get:- p A .val 
else If ob^.varno - -1 then 
begin 

(* writeln(’NEWPAIR'); *) 
q^.next:- newpaIr(property); 
get:- q^.next^.val 
end 

eIse get:- niI 

end 

end (* get *); 


function valueof(v: 
beg i n 

(* write('VALUE 
i f v - niI then 
else with do 
ATOM 

NUMBER. 

SEQ. 

OBJECT 

VARIABLE 

SELECTOR 

QVAR 

end 

end (* valueof *); 


value): value; 

OF '); print(v); *) 
vaIueof:- niI 
case key of 

: if v^.rep - nil then valueof: 
else valueof:* v A .rep; 


va I ueof:« 
va I ueof:« 
va Iueof:« 
va I ueof:« 


v; 

vaIueo 
valueo 
vaI ofq(v); 


f(local[frame + offset]); 
f(aet(valueof(obj), prop)); 


function equal(x. y: value): boolean; 


function eqob j(pi, p2: pa IrI 1st): boolean; 
var 

p: pairI ist; 
same, found: boolean; 
beg i n 

(* writeln(’EQOBJ'); *) 
same:- true; 

while (pi <> nil) and same do 
beg I n 

p:= p2; found:* false; same:* false; 
while (p <> nil) and not found do 
if p^.prop * pl^.prop then 
beg i n 

found:- true; 

same:* equaI(p~.vaI, pl^.val) 

end 

else p:« p^.next; 
pi:- pl^.next 

end; 

eqobj:* same 
end (* eqobj *); 


function eqseq(x, y: list): boolean; 
var 

same: boolean; 
beg I n 

same:* true; 

while (x <> nil) and (y <> nil) and same do 
if equaI(x^.hd, y^.hd) then 
begin 

x:« x^.tI; 
y:- y^.tl 

end 

else same:- false; 

eqseq:- (x - nil) and (y - nil) and same 
end (* eqseq *); 

begin (* equal *) 
x:« valueoffx}; 
y:* valueof(y); 

(* write(’EQUAL '); prin(x); write(' '); print(y); *) 
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if (x ■ nil) or (y - nil) then equal:* false 
else if x*.key * y*.key then 
case x*.key of 
QVAR, 

ATOM : equal:* x * y; 

NUMBER : equal:* x*.numval * y*.numval; 

OBJECT : equal:* eqobj(x*.plist, y*.pi 1st); 

SEQ : equal:* eqseq(x*.s, y*.s) 

end 

e I se equaI:= false 
end (* equal *); 

function equiv(x, y: value): boolean; 
begin 

equiv:* true; 
x:» valueoffx); 
y:= valueof(y); 

(* write(* EQUIV *); prin(x); write(* ’); print(y); *) 
if (x * nil) or (y = nil) then equiv:* false 
else if unbound(x) then 
beg i n 

x*.qval:* y; 
addtraiI(x) 

end 

else If unbound(y) then 
beg i n 

y*.qvaI:* x; 
addtraiI(y) 

end 

else equiv:* equal(x, y) 
end (* equiv *); 

procedure mkbind(formaI, actual: list); 
var 

NewFrame: LocalRange; 
begin 

bound:* true; 

NewFrame:* sp; 

while (formal <> nil) and (actual <> nil) and bound do 
begin 

local[spl:* valueof(actual*.hd); 
if locaI[sp] <> n1 I then 
beg i n 

(* prln(formal^.hd); wr!te(’ = ’); prInt(locaI[sp]); *) 
forma I:* forma I*.11; 
actual:* actual*.tI 

end 

else bound:* false; 

If sp * LocalTop then warnlng(3) 
else sp:= sp + 1; 

end; 

frame:* NewFrame; 

if (formal <> nil) or (actual <> nil) then bound:* false 
end (* mkbind *); 

procedure mkqvars(exvars: list; clear: boolean); 
var 

I: LocalRange; 
begin 

while exvars <> niI do 
beg i n 

1:* frame + exvars*.hd*.offset; 
if i >* sp then 
beg i n 

if sp » LocalTop then warnlng(3); 
sp:* i + 1; 

end; 

if clear then I oca I[i3:— nil else I oca I[iJ:■ newq; 
exvars:* exvars*.tI; 

end 

end (* mkqvars *); 

procedure call(cname: value; actual: list); 
beg i n 

(* wrlte(’CalIing *); prin(cname); write(*('); 

[continued) 
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pr I i st(actuaI); wr!teIn(')’); *) 
with cname^.rep^ do 
beg I n 

mkbInd(formaI, actual); 

(* wr I te I n( * FRAME frame); *) 
with defn A do 
beg I n 

SaveEnvfframe, tp, alternatives, ThisNode, conj); 
mkqvars(exvars, false); 
conJ;■ conjunct Ion 

end 

end; 

ThisNode:* TopNode; 
end (* call *); 

procedure backtrack; 
var 

NoAlternatIves: boolean; 
begin 

(* writeln(’Backtracklng’, ThisNode); *) 
successfuI:■ false; 

NoAlternatIves:■ true; 

while (ThisNode <> base) and NoAlternatIves do with node[ThIsNodel do 
begin 

If alternatives <> nil then 
begin 

clearq(traiIpt); 

NoAlternatIves:■ false; 
frame;- bindings; 
with a IternatIves* do 
beg I n 

mkqvars(exvars, false); 
conj;* conjunction; 

end; 

a IternatIves;* a IternatIves~.a IternatIves 

end 

e I se 

beg I n 

ThisNode;* ThisNode - 1; 
sp:* bindings 
end 

end; 

(* wr 1 teIn('BACK TRACKED TO’, ThisNode); *) 

TopNode;* ThisNode 
end (* backtrack *); 

procedure succeed; 
var 

NoContinuation: boolean; 

procedure MarkArgs(f: list); 
var 

a: value; 
begin 

(* write(*MARK *); prllst(f); writeln; *) 
while f <> nil do 
begin 

a:* local[frame + f^.hd^.offset]; 

(* write(’**> ’); print(a); *) 

If a".key = QVAR then 
beg i n 

a:= vaI ofq(a*.qvaI); 
a^.varno:* MaxVar 

end; 

f;« f~.tl 

end 

end (* MarkArgs *); 
beg i n 

(* wrIteIn(’Succeeded*, ThisNode); *) 
successfuI:* true; 

NoContinuation;* true; 

while (ThisNode <> base) and NoContinuation do with node[ThisNodel do 
begin 

(* writef’MARKING *); prexpr1(contInuation^.hd, 1); *) 

MarkArgs(continuation~.hd~.fname~.rep*.forma I); 
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frame:* node[parent].bindings; 
if continuation*.tI <> nil then 
begin 

NoContinuation:* false; 
conj:= continuation*.tI; 

end; 

ThisNode:* parent 

end; 

(* write In(’SUCCEEDED TO’, ThisNode); *) 
end (* succeed *); 

function eval(c: value; actual; list): boolean; 
var 

ok: boolean; 
p: list; 

OldSp, OldFrame: Local Range; 
beg i n 

OldSp:* sp; OldFrame:* frame; 
mkbind(c*.forma I, actual); 
if bound then 
beg i n 

c:- c*.defn; ok:* false; 
while (c <> nil) and not ok do 
begin 

p:* c*.conjunctIon; ok:* true; 
mkqvars(c*.exvars, true); 
while (p <> nil) and ok do with p*.hd* do 
beg i n 

if fname * eq then ok:* equaI(args*.hd, args*.tI*.hd) 
else ok:* evaI(fname*,rep, args); 
p:« p*.tl 

end; 

c:- c*.alternatIves; 

end; 

evaI:* ok; 

end 

e I se evaI:* false; 
sp:* OldSp; frame:* OldFrame; 
end (* eval *); 

function falsified(stmnt: value): boolean; 
begin 

If stmnt - nil then falsified:* true 

else with stmnt* do 

begin 

(* write(frame:3, ' DENY: ’); prexpr1(stmnt, 0); *) 
if fname » eq then 

falsified:* not equaI(args*.hd, args*.tI*.hd) 
else falsified:* not eval(fname*.rep, args) 

end; 

end (* falsified *); 

function denied(out: list): boolean; 
var 

d: boolean; 
begin 

(* wr1teIn(’DENIED’); *) 
d:* true; frame:* 0; 
if falsified(LastFailure) then 
beg I n 

while d and (out <> nil) do 
beg i n 

If out*.hd <> LastFailure then 
begin 

d:- falsified(out*.hd); 

if not d then failure:* out*.hd; 

end; 

out:- out*.11 

end; 

denied:* d; 
end 

else denied:* false; 

(* wrIteIn(’END DENIED'); *) 
end (* denied *); 


[continued) 
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procedure backto(s: value); 
var 

I: ControlNode; 
beg I n 

If s^.fname « eq then ThisNode:- 0 
else begin 
I:- 1; 

while (1 <> ThisNode) and (node[i].cant Inuation A .hd <> s) do 
I;- i + 1; 

ThisNode:- i; 
backtrack 

end 

end (* backto *); 

procedure execute; 
beg i n 

(* writeIn(*EXECUTING*); *) 
repeat 

successfuItrue; 

while (conj <> nil) and successful do 
with conj^.hd* do 

if fname - eq then 

if equIv(args*.hd, args".11 hd) then conj:- conj" 
else backtrack 
else call(fname, args); 
if successful then succeed; 

until (ThisNode - base) and ((conj * nil) or not successful); 
end (* execute *); 


(♦ 

function AlreadyMade(forma I: list): boolean; 
var 

found: boolean; 
p: list; 
x: value; 

function mkeg(formaI: list): list; 
beg i n 

If formal - nil then mkeg:- nil 

else mkeg:- cons(local[formal",hd".offset], mkeg(forma I".tI)) 

end; 

begin 

prIist(preveg); writeln; prIist(forma I); writeln; 

wrIte(*AIreadyMade: *); 

new(x, SEQ); 

x".key:« SEQ; 

x".s:- mkeg(formaI); 

p:- preveg; 

while (p <> nil) and not found do 

if equal(x, p".hd) then found:- true 
else p:« p".t I; 

AlreadyMade:* found; 

if found then begin write('FOUND: *); print(x); end 
else writeln(*not found*); 

if not found then preveg:- cons(newcopy(x), preveg); 
writeIn(*01d examples*); prIist(preveg); writeln; 

end; 

*) 


procedure contradictions; 
var 

d, p: list; 
implied: boolean; 
begin 

d:- conj; 

whiIe d <> nI I do 

beg i n 

if (d*.hd".state = 0) and (d".hd".imp Iicants <> nil) then 
beg i n 

if d".hd*.fname".rep".defn".aIternatives - nil then 
beg i n 

p:= d".hd*.implicants; 
while p <> nil do 
beg i n 

deIete(p".hd, out); 
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p:» p'.tl 

end 

end 

end 

else If d^.hd~.state <> 0 then 
beg i n 

p:* d*.hd~.implicants; 

implied:*® p <> nil; 

while (p <> nil) and implied do 

if p^.hd^.state * 0 then p:= p~.tl 
else implied:®* false; 

if not implied and not covered(d*.hd. d^.tl) then 
conc(out, d^.hd); 

end; 

d:« d^.tl 

end 

end (* contradictions *); 

function simp I 1fied(conj: list); list; 
begin 

if conj * nil then simplified:* nil 

else if conj^.hd^.state <> 0 then simplified :* simp Iified(conj*.11) 
else if covered(conj^.hd, conj^.tl) then 
simplified:* simplified(conj A .11) 
else simplified:* cons(con.hd, simp Iified(conj".11)) 
end (* simplified *); 

procedure warning; 
beg i n 

wr ite(’WARNING: *); 
case msgno of 

1: wr itelnf’Local Trail Overflow*); 

2: writeln(*Control Stack Overflow*); 

3: writeIn(*LocaI Stack Overflow*); 

end; 

? oto 1; 

* warning *); 

begin (* prove *) 

StartTime:* clock; 
start:* simpIified(conj); 
out:* nil; 
contradict ions; 

(* wr1teIn(’Make’); prconj(conj); *) 

(* write(’with (*); prlist(formal); 

write(*) (*); pr11st(actual); wrIteln(*)*); *) 

repeat 

TopNode:* 0; ThisNode:* 0; base:* 0; frame:* 0; sp:* 0; tp:* 0; 
LastFailure:* nil; failure:* nil; LastNode:* 0; 
node[0].bindings:* 0; 
conJ:■ start; 

If actual ■ nil then mkqvars(formaI, false) 
else mkbInd(forma I, actual); 
mkqvars(exvars, false); 

(* wr1teIn(*T0 BE DENIED:*); prconj(out); *) 

prove:* true; 
repeat 

execute; (* writeIn(*EXEC FINISHED*); show(formaI); *) 
if successful then 

if denied(out) then begin show(formaI); writeln end 
else begin 

(* wr1te(’FAILED BECAUSE OF ’); prexpr1(faiIure, 0); *) 
if failure » LastFailure then 
begin 

ThisNode:* LastNode - 1; 

(* writeIn(’SAME PROBLEM’); dumpcontrol; *) 

end 

else ThisNode:* TopNode; 

LastFailure:* failure; 

backtrack; (* show(formaI); show(exvars); *) 
LastNode:- ThisNode; 

(* wr1teIn(’LastNode is*» LastNode); *) 
successful:* false 


(continued) 
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end 

else prove:- false; 
until successful or (ThisNode - 0); 

If not successful then 
beg t n 

delete(LastFailure, out); 

(* wrIt«('REMOVED *); prsxpr1(LastFailure, 0); *) 
end 

untiI successful; 

1: prove:- successful; 

freeout(out); freeout(start); 
gtI me:- gtime + (clock - StartTime); 
end (* prove *); 

(* 

** Make Primary Statements 

*********************************************++*+++++++++++++++++^^*^^^ 

*) 

(* this file contains the procedures to generate the primary statements *) 

procedure primary(var description, args, exvars: list; eg: value); 
var 

p: value; 

I: list; 
i: VarRange; 

procedure describe(lt: VarRange); 
var 

p: pair Iist; 

procedure ident(v1, v2: value); 
var 

s: value; 
beg i n 

new(s, STATEMENT); 

concfItemTvl*.offset].is in, s); 

conc(item[v2*.offsetJ.is in, s); 

conc(description, s); 

with s* do 

beg i n 

key:- STATEMENT; 
state:- 0; 

(* LastTrial:- true; *) 
imp Iicants:- nil; 
fname:* eq; 

args:- cons(v1, cons(v2, nil)) 

end 

end (* ident *); 

procedure eqstmnt(obj, prop, val: value); 
var 

s, get: value; 
beg i n 

new(s, STATEMENT); 

conc(item[obj*.offset],isin, s); 

conc(description, s); 

with s* do 

beg i n 

key:- STATEMENT; 
state:- 0; 

(* LastTrial:- true; *) 
imp Iicants:- nil; 
fname:- eq; 
args:- nil 

end; 

new(get, SELECTOR); 
get*.key:- SELECTOR; 
get*.obj:- obj; 
get*.prop:- prop; 
conc(s*.args, get); 

If val*.key - ATOM then 

if val*.rep <> niI then 
beg i n 

if vaI*.rep*.varno < 0 then 
beg i n 
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voI:« vaI *.rep; 
subst[nextvar]:* val; 
val~.varno:® nextvar; 
vaI: = newvar; 
conc(exvars, val); 
describe(val^.offset) 

end 

else val:® i tem[va I ~. r ep'". varno] . varce I I ; 
conc(Item[vaIoffset],is in, s); 

end; 

conc(s^.args, val) 
end (* eqstmnt *); 


begin (* describe *) 

p:® subst[it]~.plist; 

if it ® subst[it]~. varno then 

while p <> nil do with p~ do 
begin 

eqstmnt(1tem[11].varceI I, prop, val); 
p:« next 

else ident(item[it].varce11, item[subst[it]~.varno].varceI I) 
end (* describe *); 

begin (* primary *) #N , * v 

(* write('Begin generating primary statements from ); print^eg;; *; 

I:® eg~.s; 
while I <> n1 I do 
beg i n 

p:- l^.hd^.rep; 

if p^.varno < 0 then p*.varno:® nextvar; 
subst[nextvar]:® p; 
conc(args, newvar); 

is- r.ti 

end; # 

for i:■ 0 to nextvar - 1 do describe(i) 
end (* primary *); 


(* 

*****************♦**♦***♦♦♦***♦*♦♦*♦*♦**♦♦♦********♦*******♦************♦******* 
** Pattern Matcher 

***++***+******+**************************************************************** 

o 


(* this file contains the statement comparison routines *) 

procedure bind(v, term: value; frame: SubstRange); 
begin 

if v^.key ® VARIABLE then 

subst[frame + v*.offset]:* term 
else error(8) 
end (* bind *); 

function isbound(v: value; var term: value; frame: SubstRange): boolean; 
beg i n 

if v^.key * VARIABLE then 

term:® subst[frame + v*.offset] 
else error(9); 
isbound:® term <> nil 
end (* isbound *); 

procedure RecordSubst(n: SubstRange); 
begin . . 

if LastSubst « SubTraiHop then error(10); 

LastSubst:® LastSubst + 1; 

subtra1 I[LastSubst]:® n; 

if n > TopSubst then TopSubst:® n; 

end; 

procedure ForgetSubst(btp: SubstRange); 
begin 

for LastSubst:- LastSubst downto btp + 1 do 
subst[subtraiI[LastSubst]]:- nil; 

LastSubst:- btp 

end; 


(continued) 
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function unify(term1: value; f1: SubstRange; 

term2: value; f2: SubstRange); boolean; 

var 

p; value; 
beg i n 

If isbound(term1, p, fl) then unify:- unlfy(p, fl, term2, f2) 
else beg In 7 

bind(term1, term2, fl); 

RecordSubst(base + terml*.offset); 
unify:- true 
end 

else If term2'.key - VARIABLE then unify:- unify(term2. f2. terml, fl) 
else If terml''.key - term2'.key then 
case terml*.key of 
OBJECT, 

unify:- terml - term2; 
unify:- terml*.numvaI - term2*.numvaI; 

If terml*.prop - term2*.prop then 

unify:- unify(term1*.obj, fl, term2*.obj, f2) 
else unify:- false 7 


ATOM 
NUMBER 
SELECTOR 


end 

else unify:- false 
end (* unify *); 


function eqstmnt(s1, s2: value): boolean; 
var 

p. q: list; 
cmp; boolean; 
begin 

(* wrlltelnCComparlng:’); prexpr1(s1. 1); prexpr1(s2, 1); *) 

If si .fname - s2~. fname then 
beg I n 

p:- sl-.args; q:- s2'\args; 
cmp:- true; 

while (p <> nil) and (q <> nil) and cmp do 
If unlfy(p'.hd, 0, q".hd, base) then 
beg i n 

p:- p*.tl; q:« q*.tI; 
end 

else cmp:- false; 

eqstmnt:- (p - nil) and (q - nil) and cmp 

end 

else eqstmnt:* false; 

(* if (p - nil) ond (q - nil) and cmp then writeIn(’SimiI or’); *) 
(* prInt(subst[0]); *) J ‘ ' 

end (* eqstmnt *); 

function newassoc(i, u: value): alist; 
var 

a: alist; 
beg i n 

new(a); 
with a* do 
begin 

i nd:= i; 

Usedln:- cons(u, nil); 
rest:- niI 

end; 

newassoc:- a 
end (* newassoc *); 


procedure index(stmnt, occurs: value); 
var 

a: alist; found: boolean; 
beg i n 

if memory -nil then 

memory:- newassoc(stmnt, occurs) 
else begin 

a:- memory; found:- false; 
repeat 

base:- nextvar; TopSubst:- 0; 
with a* do 

if eqstmnt(stmnt, ind) then 
beg i n 
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if not member(occurs, Usedln) then 
conc(UsedIn, occurs); 
found:* true 

end 

else if rest = niI then 
beg i n 

rest:* newassoc(stmnt, occurs); 
found:* true 

end 

else a: = a*.rest; 

ForgetSubst(0); 
untii found or (a = nil) 

end 

end (* index *); 


procedure Iookup(stmnt: value; var occurs: list); 
var 

a: alist; found: boolean; 

NewBase: SubstRange; 

OldBase: SubstRange; 
beg i n 

occurs:* nil; found:* false; 
a:= memory; NewBase:* LastSubst; 

OldBase:* base; base:* TopSubst + 1; 
while (a <> nil) and not found do 
begin 

with a* do 

if eqstmnt(stmnt, ind) then 
begin 

(* writeln(*Statements are similar*); *) 
occurs:* Usedln; 
found:* true 


end 

else a:* rest; 

ForgetSubst(NewBase); 

TopSubst:* base - 1; base:* OldBase; 
(* dumpsubst(10); *) 


end 

(* 


end 

(* lookup 


*); 


******************************************************************************** 

Generalization Routines 

it***************************************************************************** 


*) 


procedure remove(stmnt: value); 
beg i n 

with stmnt* do if state >* 0 then state:* state + 1; 

(* write(’REMOVE’, stmnt*.state, * *); prexprl(stmnt, 0); *) 

end; 


procedure rep Iace(stmnt: value); 
beg i n 

with stmnt* do if state > 0 then state:* state - 1; 

(* wr i te(’REPLACE*, stmnt*.state); prexpr1(stmnt. 1) *) 

end; 

procedure restore(var StmntsOut: list; PartOut: list); 
var 

p: list; 
begin 

(* writeln(*Restoring:*); prconj(StmntsOut); *) 

while StmntsOut <> PartOut do 

begin 

rep Iace(StmntsOut*.hd); 
p:« StmntsOut; 

StmntsOut:* StmntsOut*.tI; 
dispose(p) 

end 

end (* restore *); 

procedure generallze(descriptIon, formal, exvars: list); 
var 

p: list; 


(continued) 
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function contained(description: list): boolean; 


procedure SetLostTria I; 
var 

p: list; 
beg i n 

p:« description; 
while p <> nil do 
beg I n 

with p*.hd* do LastTrial:- (state » 0); 

P:* P A .tl 

end 

end; 

*) 


beg i n 

writeIn(’Testing:’); prconj(description); 
wr i teIn('Is *); 

if prove(description. formal, nil, exvars) then 
beg i n 

wr ite(* recognized by the concept? '); 
readvaI(answer); 
contained:* (answer - yes); 

(* if (answer - yes) then SetLastTria I; *) 

end 

^ else begin contained:- false; wr1teIn(*CouIdn**t make example’) end; 

write(’contained In the target? '); readvaI(answer); 
contained:- (answer * yes); 

*) 

end (* contained *); 

function TryConceptsWith(focus: value; restricting: list; 

Relaxation: value): boolean; 

var 

usedin: list; 

StmntsOut: list; 

OldBase: SubstRange; 

function CheckConcept(name: value): boolean; 
var 

matched, duplicate: boolean; 

Stmnt, def: value; 

FormalArgs: list; 

function TrIedBefore(name: value; FormalArgs: list): boolean; 
var 

desc: list; found, AlISame: boolean; 
count: integer; 

function CommonArgs(a1, a2: list): integer; 
var 

count, length: integer; 
beg i n 

(* writeln; prconj(il); writeln(’-’); prconj(12); *) 

count:- 0; length:- 0; JV ’ 

while (al <> nil) and (a2 <> nil) do 

begin 

If a1*.hd — a2*.hd then count:- count + 1; 
al:- al*.tI; a2:- a2*.tl; 
length:- length + 1 

end; 

CommonArgs:- count; 

AlISame:- (length - count) 
end (* CommonArgs *); 

begin (* TriedBefore *) 

(* write(’Has ’); prin(nome); write(’(’); 

prIist(FormalArgs); write(’) been tried before?’); *) 

desc:- description; 

found:- false; 

while (desc <> nil) and not found do 
beg i n 

with desc*.hd* do 

if fname * name then 
begin 
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count:= CommonArgs(FormaIArgs, args); 
if AllSame then found:* true 
else if (state = 0) 

and (count <> 0) 

and (restricting <> nil) 

then found:* true 

end; 

(* insert *) if found and (desc*.hd*.state = -2) then 

begin 

Stmnt:* desc*.hd; 

Stmnt*.state:* 0; 
prexprl(desc*.hd, 1) 

end; 

desc:* desc*.tI 

end; 

TriedBefore:* found and (Stmnt * nil); 

(* if found then writeln(* Yes.') else writeln(* No.*); *) 
end (* TriedBefore *); 

function findargs(formaI: list): list; 
var 

v: value; I: list; 
beg i n 

if formal * nil then findargs:* nil 
else If i sbound( f orma I *. hd, v, bose) then 
begin 

If v*.key * OBJECT then 

v:= item[v*.varno].varceI I; 

I:* findargs(formaI*.tI); 
if member(v, I) then 
begin 

dupIicate:* true; 

(* writ eIn(* DUPLICATE *) *) 

end; 

findargs:* cons(v, I) 
end 

else error(ll); 
end (* findargs *); 

function NewStatement(actuaI: list): value; 
var 

stmnt: value; 
begin 

new(stmnt, STATEMENT); 
with stmnt* do 
beg i n 

key:- STATEMENT; 
state:* 0; 

copy(StmntsOut, imp Iicants); 
fname:- name; 
args:* actual 

end; 

conc(description, stmnt); 

NewStatement:* stmnt 
end (* NewStatement *); 

procedure OccursIn(s: value); 
var 

a: list; v: value; 
begin 

a:- s A .args; 
while a <> nil do 
begin 

v:» a*.hd; 

if v*.key - SELECTOR then v:- v*.obj; 
conc(item[v*.offset].is in, s); 
a:- a*.tI 

end 

end (* Occursin *); 

function CanNotRemove(s: value): boolean; 
var 

NotOk: boolean; 
a: list; 
v: value; 

(continued) 
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function NoOtherRef(v: volue): booleon; 
vor 

NoRef: boolean; 

•list: list; 
begin 

(* wrIteIn(’enter NO OTHER REF’); 
prlnt(v); prI Ist(FormaIArgs); wrtteln; *) 

If member(v, FormalArgs) then NoOtherRef:- false 
else begin 

NoRef:* true; 

si 1stitem[v*.offset].isin; 

(* wrltsln('SLIST’); prconJ(si 1st); *) 
while (si 1st <> nil) and NoRef do 
beg i n 

with siist^.hcTdo 

If (fname <> eq) and (state * 0) then 

if member(v, args) then NoRef:* false; 
si 1st;* siist^.tI; 

end; 

NoOtherRef:** NoRef; 

(* if NoRef then wr!teln(’No Ref’); *) 

end; 

end (* NoOtherRef *); 


function Parentln(v: value); boolean; 
var 

Parln; boolean; 
slist: list; 
s: value; 
beg I n 

Parln:* false; 

slist:* Item[v*.offset],isin; 

(* wrlteln('SLIST’); prconj(sI 1st); *) 
while (slist <> nil) and not Parln do 
beg i n 

s:■ si ist~.hd; 

(* prexpr1(s, 1); *) 
if s*.fname * eq then 

if not member(s, StmntsOut) then 
If s^.state « 0 then 

if s^.args^.tn.hd * v then 
Parln:* true; 
slist:* siist^.tI 


if Parln then 

writeIn(’PARIN’) 
else writeln('NOT PARIN'); 

Parentln:* Parln 
end (* Parentln *); 

function NoSpec(a1, a2: value): boolean; 
begin 

if (al^.key = SELECTOR) and (a2 y '.key <> VARIABLE) then 
NoSpec:= Parentln(al^.obj) and NoOtherRef(a1~.obi) 
else NoSpec:* false 
end (* NoSpec *); 


begin (* CanNotRemove *) 

(* wrIte(’TRY REMOVING ’): prexpr1(s, 0); *) 
a:* s^.args; NotOk:* false; 
if s^.fname * eq then 

NotOk:* NoSpec(a^.hd, a'.tl^.hd) 
else while (a <> nil) and not NotOk do 
beg I n 

v:* a^.hd; 

if v^.key * VARIABLE then 

if member(v, formal) then NotOk:* NoOtherRef(v) 
e i S * | Not0k: “ Paren ^In(v) and NoOtherRef(v); 

end; 

CanNotRemove:* NotOk; 

if NotOk then 
begin 

write('CANNOT REMOVE '); 
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prexprl(s, 0) 

end 

end (* CanNotRemove *); 

function CreateStatement: boolean; 
var 

failure: boo Iean; 

procedure FindRemovabIe; 
var 

p: list; 
beg i n 

p: — StmntsOut; 
while p <> nil do 
begin 

if p^.hd".state - 1 then . 

if CanNotRemove(p^.hd) then replace(p .hd) 
p:- p^.tl; 

end; 

end (* FindRemovabIe *); 

function restricts(L1, L2: list): boolean; 
var 

found: boolean; 
beg i n 

if L2 « nil then restricts:- true 
else begin 

found:- false; 

while (LI <> nil) and not found do 

if member (LI'' .hd. L2) then found:- true 
else LI:- Ll^.tl; 
restricts:- found 

end 

end (* restricts *); 
function NotRelaxed: boolean; 

b6 ^ if Relaxation - nil then NotRelaxed:- false 
else NotRelaxed:- CanNotRemove(ReIaxation) 
end (* NotRelaxed *); 


begin (* CreateStatement *) 
dupIicate:- false; 

failure:- false; N 

FormalArgs:- findargs(name~.rep .formal); 
if dupIicate then 
beg i n 

failure:- true; 

(* write(’DUPLICATE *); prin(name); 


l* wrixei, uurLiL/nit /» K' -/» . /#N ,\ 

write('(*); prIist(Forma IArgs); wrlteln( ) ); *) 


else if TriedBefore(name, FormalArgs) then failure:- true 
else begin 

FindRemovable; ^ # N .. 

if not restricts(Forma IArgs » restricting) then 
begin 

failure:- true; 

write('NOT RESTRICTING ’); prin(name); 

wr ite(*(’); prIist(FormalArgs); writeln(’) ); 

end 

else if NotRelaxed then failure:- true 
else if Stmnt -nil then 


begin 

Stmnt:= NewStatemen 
OccursIn(Stmnt); 


t(Forma IArgs); 


end 


end; * 

if failure then freeout(Forma IArgs); 
CreateStatement:- failure 
end (* CreateStatement *); 


function Contains(conJ: list): boolean; 
var 


I continued ) 
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(* writeO# 


(**) 

(* insert *) 
(**) 


MadeMatch: booleon; 

PartOut: list; 

OldSubst: SubstRange; 
desc: list; 

function qua I 1fied(NewStmnt: value): boolean; 
var 

imp I I cants: list; 
q: boolean; 
tmp: WayOut; 
beg i n 

If not contained(descriptI on) then 
beg i n 

(* wr iteIn(*QuaIifying generalization*); *) 
implicants:- StmntsOut; 
q:« false; 

If restricting - nil then repeat 

If implIcants".hd".state * 1 then 
begin 

* implicants".hd".state:1, *: *); prexpr1(imp Iicants".hd, 0); ★) 

(* rep I ace(implicants".hd); *) 
tmp:- implleants".hd".state; 
implicants".hd".state:- 0 ; 
if TryConceptsWith(Imp I I cants".hd. 

FormalArgs, nil) 

then q:- true 
else begin 

(* remove(Imp Iicants".hd); *) 
implicants".hd".state:- tmp 

end; 

end; 

Implicants:- imp Iicants".11; 
until q or (implicants » nil); 

If not q then 

If restricting - nil then NewStmnt".state:- -1 
else NewStmnt".state :- -2; 
if not q then remove(NewStmnt); 
qua I IfIed:- q; 

(* if q then wrIteIn(‘QUALIFIED*); *) 
end 

eIse qua I Ifled:* true 
end (* qua Iified *); 

procedure relax(s: value); 
var 

i: list; q: boo Iean; 
beg i n 

(* write(’Try relaxing *); prexpr1(s, 0); *) 
remove(s); 

i:- s".imp Iicants; q:= false; 
while (i <> nil) and not q do 
beg i n 

if i".hd".state > 0 then 
begin 

rep Iace(f".hd) ; 

if TryConceptsWith(i~.hd, nil. s) then q:- true 
else remove(i^.hd); 

end; 

i:« i-.tl 

end; 

if not q then replace(s) 
end (* relax *); 

procedure TryUnRemoved(I: list): 
begin 

while I <> nI I do 
beg i n 

with I".hd" do 

if (fname <> eq) and (state = 0) then 
relax(l".hd); 

I:- r.tl 

end 

end (* TryUnRemoved *); 

function restricts2(L1. L2: list): boolean- 
var 

length, count: integer; 
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(* sent *) 


begin 

if L2 * nil then restricts2:= true 
else begin 

length:* 0; count:* 0; 
while (LI <> nil) 

and ((count * 0) or (count * length)) 
do 

begin 

if member(LI *.hd, L2) then count:* count + 1; 

LI:* LI*.tI; 
length:* length + 1 

end; 

restricts2:- (count > 0) and (count < length); 

wr i teIn(* count * *. count:1, * length * *, length:1) 

end 

end (* restricts2 *); 

function NoChange: boolean; 
var 

I: list; q: boolean; 
begin 

(* writeIn(’Has the trial changed?*); *) 

(* if state of stmnt is > 1 then it has been removed before 
except for focus during restriction, this may be 1 *) 
q: = true; 
i:- StmntsOut; 
while (i <> nil) and q do 
beg i n 

if l*.hd*.state * 1 then 

if (restricting <> nil) 
and (i*.hd * focus) 
then i:* i*.tl 
else q:* false 
else l:« l*.tl; 

end; 

If q and (restricting <> nil) then 

q:«= not rest r I cts2(Forma I Args , restricting); 
if q then 
begin 

write(*N0 CHANGE, REMOVE *); 
prexpr1(Stmnt, 0); 

end; 

NoChange:* q 
end (* NoChange *); 

begin (* Contains *) 

(* wrIteln(*Entering Contains*); *) 

Stmnt:* nil; 
i f conj * niI then 

if not member(focus, StmntsOut) then Contains:* false 
else if CreateStatement then Contains:* false 
else if NoChange then 
begin 

remove(Stmnt); 

Stmnt*.state:* -1; 

Contains:* false 

end 

else if qualified(Stmnt) then 
begin 

Contains:* true; 

TryUnRemoved(StmntsOut) 

end 

else Contains:* false 
else begin 

01dSubst:■ LastSubst; 

PartOut:* StmntsOut; 
desc:* description; 

MadeMatch:- false; 
while desc <> niI do 
begin 

if eqstmnt(desc*.hd. conj*.hd) 
and not member(desc*.hd, StmntsOut) 
then begin 

StmntsOut:* cons(desc*.hd, StmntsOut); 


(continued) 
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remove(desc*.hd); 
if Contains(conj^.tI) then 
beg i n 

MadeMatch:* true; 

StmntsOut:* PartOut 

end 

else res tore(StmntsOut, PartOut); 

end; 

ForgetSubst(OldSubst); 
desc:* desc^.tl 

end; 

(* if MadeMatch then writeIn(’More General*); *) 
Contains:* MadeMatch 

end 

end (* Contains *); 

begin (* CheckConcept *) 

(* wr!te('Checking ’); print(name); *) 

def:« name'", rep^.defn; 

matched:* false; duplicate:* false; 

while (d* f< > nil) ond (def <> trial) and not matched do 
if Contains(def~.conjunct ion) then matched:* true 
else def:» def^.a Iternatives; 

CheckConcept:* matched 
end (* CheckConcept *); 


(* act 


begin (* TryConceptsWith *) 

(* write(’Trying with ’); prexprl(focus. 0); *) 
TryConceptsWith:- false; 

StmntsOut:■ nil; 

01 dBase:* base; base:* TopSubst + 1; 
lookup(focus, usedin); 

(* wrlte(’PosslbMItles are ’); pr11st(usedin); writeln; *) 
while usedin <> nil do ' 

beg i n 

if (usedin".hd^.rep^.defn".alternatives <> nil) 

*) (* or (usedin".hd*.rep".formal".tl - nil) *) 

or (restricting <> nil) 
then 


If CheckConcept(usedIn".hd) then TryConceptsWithtrue- 
usedin:- usedin".tl 1 

end; 

TopSubst:* base - 1; base:* OldBase; 
end (* TryConceptsWith *); 


begin (* generalize *) 

TopSubst:* nextvar - 1; 
p:= description; 
whiIe p <> niI do 
beg i n 

If p^.hd*.state <* 0 then 

if TryConceptsWith(p".hd, nil. nil) then 
(* able to generalize *); 
p:= p".tl 

end 

end (* generalize *); 



(* this file contains the top-level learning strategy *) 

procedure simplify(var description: list); 
beg i n 

if description <> nil then 
beg i n 

(* prexpr1(description".hd, 1); *) 
if description".hd".state <> 0 then 
beg i n 

(* writeIn(* NOT IN*); *) 
description:* description~.tI; 
simp Iify(description) 

end 

else if covered(description".hd, description".tI) then 
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begin 

(* writ eIn(* COVERED’); *) 
description:* description*.tI; 
simplify(description) 

end 

else simplify(description*.tl) 

end 

end (* simplify *); 

procedure creote(description. vors, exvars: list; name: value); 
var 

p: value; 
begin 

new(tria I, DISJUNCTION); 
with t r1 a I * do 
beg i n 

key:* DISJUNCTION; 
conjunction:* description; 
a Iternatives:* niI 

end; 

trial*.exvars:■ exvars; 

with name*.rep* do 
begin 

formal:* vars; 

if defn - nil then defn:- trial 
else begin 

p:* defn; 

while p*.a Iternatives <> nil do p:* p*.alternatives; 
p*.a Iternat1ves:* trial 

end 

end; 

end (* create *); 

procedure remember(name: value; description: list); 
beg i n 

while description <> nil do 
begin 

index(descript1 on*.hd, name); 
description:* descr1ption*.tI; 

end 

end (* remember *); 

procedure cleanup; 
begin 

for nextvar:■ nextvar - 1 downto 0 do 
beg i n 

item[nextvar].is1n:* nil; 
subst[nextvarl*.varno:« -1; 
substtnextvarJ:* nil; 

end; 

nextvar:* 0; 

ForgetSubst(0); 

LastSubst:* 0; 
end (* cleanup *); 

(* learn a conjunction of the concept c. given a positive example and 
a list of negative examples *) 

procedure LearnConj(conceptname, example: value); 

VOr . • 4 

description, args, exvars: list; 
beg i n 

description:* nil; args:* nil; exvars:* nil, 

preveg:* cons(exampIe, nil); 

primary(description, args, exvars, example); 

create(description, args, exvars, conceptname); 

generali ze(description, args, exvars); 

simplify(t ria I *.con junction); 

prconj(trial*.con junction); 

remember(conceptname, description); 

cIeanup; 

end (* LearnConj *); 


( continued ) 
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procedure LearnedCons(nome: value); 
var 

c: value; 
begin 

If name A .rep * n!I then 
begin 

new(c, CONCEPT); 
with c A do 
beg I n 

key:- CONCEPT; 
forma Inil; 
defn:« nlI 

end; 

name A .rep:« c 

end 

else c:- name A .rep; 
end (* LearnedCons *); 

procedure learn; 
var 

conceptname, eg: value; 
start: integer; 

AIILearnt: boolean; 
beg I n 

AIILearnt:- false; 
repeat 

wrIte(’What is the name of the concept? *); 
readval(conceptname); 
until conceptname*.key « ATOM; 

LearnedCons(conceptname); 
start:- clock; gtime:- 0; 
repeat 

wrIte('Show me an example of ’); pr in(conceptname); writef: ’): 
readvaI(eg); v /. 

if eg « no then AIILearnt:- true 

else if eg*.key - SEQ then LearnConJ(conceptname, eg) 
else wrIteIn('Examp Ie must be a list.*) 
untiI All Learnt; 

wrIte(’DescrIption of prIn(conceptname); writelnf’ is:’)- 
prexpr(conceptnamerep); 
start:- clock - start; 

writeIn(’Learnt In *, (start/1000):1:2. * secs*); 

(* wrlteln(*Object generation *, gtime*100/start:1:1. • X')• *) 


(* 


Initialization 


****************** 



******** 


procedure init; 
var 

s: string; 
i : SubstRange; 
j: HashRange; 
beg i n 

for j:- 0 to HashMax do hashtabIe[j]:- nil; 

s:= '■ *; eq:* find(s); 

s :* * no *; no:- find(s); 

s:= *yes *; yes:= find(s); 

for nextvar:= 0 to MaxVar do 

beg i n 

new(item[nextvar].varceI I); 
with item[nextvar].varceI I A do 
beg i n 

key:- VARIABLE; 
offset:- nextvar 

end; 

item[nextvar].isin:« nil; 

end; 

for i:- 0 to SubstTop do subs t [ i ]: *= nil; 
nextvar:- 0; 

NoMoreVars:- false; 

ReadMem:- true; 

LastSubst:- 0; 
base:- 0; 
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end 


memory:* nil; 

UsedPairs;* 

nil; 

(* init *); 


procedure error; 

beg i n 


wr i te1n 

; 

wr i te(* 

*** ERROR 

case msgno of 

1 : 

wr ite1n( 

2 : 

wr ite1n( 

3 : 

wr i te1n( 

4 : 

wr iteln( 

5 : 

wr i te1n( 

6: 

wr i te1nf 

7: 

wr i te1n( 

8: 

wr i te1nf 

9: 

wr i te1n( 

10 : 

wr 1 te1n( 

11: 

wr i te1n( 

12 : 

wr i te1nf 

13 : 

wr i te1n( 


*»> *); 

No more variables’); 

MI spIaced symboI’); 

Strange list*); 

Strange object*); 

’Property name expected’); 

’Strange value*}; 

’Atom expected*); 

’Tried to bind non-variable’); 

’isbound: only variables may be bound*); 
’Substitiution trail overflow*); 

’Can* *t make formal paramaters’); 

’expecting * *(**'); 

’Strnnt expected*); 


end; 


end; 
goto 0; 


it****************************************************************************** 

^ Input Memory File 


******************* 
*) 


procedure inconcept(* var name: value *); 
var 

p, d: value; 
f: list; 


procedure readstmnt(var s: value); 
var 

v: value; 

begin . v 

(* writeln(’READ STATEMENT’): *) 
skipblanks; 
new(s , STATEMENT); 
with s A do 
begin 

key;- STATEMENT; 
state:- 0; 
imp Iicants;- nil; 
readval(v); 
if v*.key - ATOM then 
begin 

skipblanks; 

if nextch <> *(’ then error(12); 

fname:= v; 

readlist(args, *)*) 

end 

else if v^.key In [VARIABLE, SELECTOR] then 
begin 

lookfor(*-*); 
fname:- eq; 
new(args); 
args^.hd:- v; 
new(args~.tI); 
readvaI(args*.tI A .hd); 
args^.tI^.tInil 

end 

else error(13) 

end 

end (* readstmnt *); 

procedure stmnt 11st(vor s 11st; list; var endch: char); 
beg 1 n 

skipblanks; 

If nextch In [’]*, ’|’] th#n 
begin 


(continued) 
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reodch(endch); 

8IIst:■ nil 

end 

else begin 

new(sI ist); 
r eadstmnt(sIist A .hd); 
stmntlIst(sIist^.tI, endch) 

end 

end (* stmntlist *); 

function dIsjunct(var d: value); boolean* 
var * 

surrounded: boolean; 
endch: char; 
beg i n 

(* wr1teIn('READ DISJUNCT’); *) 
new(d, DISJUNCTION); 
with d A do 
beg I n 

d^.key:= DISJUNCTION; 

If nextch - ’[' then 
beg i n 

advance; 

read Iist(exvars, ’:'); 
surrounded:- true; 
end 

else begin exvars:- nil; surrounded:- false end; 
stmntlist(conjunction, endch); 
alternatives:- niI; 
remember(name, conjunction); 
disjunct:- (endch « *|*) or surrounded 

end 

end (* disjunct *); 

procedure disjlist(var d; value); 
beg i n 

skipbIanks; 
i f nextch - *|’ then 
beg i n 

advance; 
skipblanks 

end; 

if nextch « ']’ then 
begin 

advance; 
d:« nil 
end 

else begin 

if disjunct(d) then disjIist(d~.a Iternatives) 
else d~.a Iternatives:= nil 

end 

end (* disjlist *); 


beg i n 

(* wrIteIn(’READ CONCEPT'); ») 
read Iist(f, 
disjlist(d); 
if name' 1 .rep = ni I then 
beg i n 

new(name^.rep, CONCEPT); 
with name^.rep^ do 
beg i n 

key:- CONCEPT; 
forma I:— f; 
defn:= d 

end 

end 

else with name^.rep^ do 
beg i n 

p:- defn; 

while p^.alternatives <> nil do p:= p^.alternatives* 
p^.alternatives:* d 

end; 

(* prexpr(name^.rep); *) 
end (* inconcept *); 
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(* 

******************************************************************************** 
** Startup 

******************************************************************************** 

*) 


begin (* main *) 

(* stIimit(3000000); *) 
wr iteIn('I suppose you wan 


i n 11; 
look; 

ReadMem:= false; 
ForgetSubst(0); 
repeat 

I earn; 

write(’Do you want to 
skipbIanks; 
readvaI(answer); 
unt i I answer =* no; 

(* prmem; *) 

0; writeIn('End of run') 


t to teach me more silly concepts?' 


teach me another concept? '); 


); 


end. 


MARVIN.RUN 

"Machine Learning," by Angelos T. Kolokouris, November 1986, page 225. 


*** MEMFILE 

*** 

*** The memflle contains descriptions of the 
*** objects about which we will talk. 

*** 


*** 
*** 
*** 
* * * 
*** 


*** The binary digits 0 and 1 *** 
d0 = <value:0> 
dl « <vaIue:1> 

*** The binary numbers one through four *** 

one = <Ie f t:niI;right:d1> 

two * cleft:one;right:d0> 

three - <1eft;one;right:d1> 

four « <left;two;right;d0> 


*** 

*** 


A SESSION 


*** 

*** 

*** 

♦** 

*** 

*** 


*** All user responses are enclosed in *’s 
*** bear in mind that these should be not be 
*** typed in a real interactive session with 
*** MARVIN. 

*** Comments are enclosed in ***’s and do not *** 
**♦ appear in a real session. *** 

*** They should be ommltted from the memfile *** 
*** *** 


I suppose you want to teach me more silly concepts? 
What Is the name of the concept? * b-digit * 

Show me an example of b-digit: * (d0) * 

*** Note list format of this input. *** 

X0.value « 0 

Show me an example of b-digit: * (dl) * 

X0.value - 1 

Show me an example of b-digit: * no * 

*** There are no other binary digits *** 
Description of b-digit is: 

[X0: 

X0.value ■ 0 
OR 

X0.value ■ 1 

] 


[continued) 
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Learnt in 0.05 secs 

Do you want to teach me another concept? * yes * 
What Is the name of the concept? * b-num * 

Show me an example of b-num: * (one) * 

Testing: 

X0.left - nil 
X0.right - XI 
1> XI.vaIue - 1 
b-digit(XI) 

Is 

X0 ■ < I e f t: nil; right: <value: 0» 

recognized by the concept? * no * 

*** We are not including zero in our binary *** 
*** number scheme. *** 

X0.left = nil 
X0.right = XI 
XI.vaIue * 1 

Show me an example of b-num: * (two) * 

Testing: 



X0 

.left * 

XI 

1> 

XI 

.left * 

nil 

1> 

XI 

.right ■ 

X2 

1> 

X2 

.value » 

1 


X0 

. r i ght » 

X3 


X3 

.value = 

0 


b-num(X1) 



Is 

X0 ■ cleft: cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0»; right: cvalue: 0» 

recognized by the concept? * yes * 

Testing: 



X0 

.left - XI 

1> 

XI 

.left * n 

i 1 

1> 

XI 

.right ■ 

X2 

1> 

X2 

.value * 

1 


X0 

.right - 

X3 

1> 

X3 

.value = 

0 


b-i 

num(X1) 



b- 

digit(X3) 



Is 

X0 * cleft: cleft: cleft: nil; right: Cvalue: 1»; right: cvalue: 0»; right: cvalue: 1» 

recognized by the concept? * yes * 

X0.left « XI 
X0.right * X3 
b-num(X1) 
b-digit(X3) 

Show me an example of b-num: * no * 

Description of b-num is: 

[X0: 

[E XI: 

X0.left - nil 
X0.right - XI 
XI.vaIue ■ 1 

] 

OR 

[E XI. X2, X3: 

X0.left - XI 
X0.right - X3 
b-num(X1) 
b-digit(X3) 


Learnt in 0.25 secs 

Do you want to teach me another concept? * yes * 
What is the name of the concept? * lessd * 

*** Before we can teach the concept of less- *** 

*** than for binary numbers we must show *** 

*** MARVIN what less-than for binary-digits *** 

*** is. *** 

Show me an example of lessd: * (d0,d1) * 

Test Ing: 

1> X0.value * 0 

XI.vaIue ■ 1 
b-digit(X0) 
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Is 

X0 * <value: 1> 

XI - <value: 1> 

recognized by the concept? * no * 

*** We are defining less than not less than *** 
*** or equaI. *** 

Testing: 

X0.value = 0 
1> XI.vaI ue - 1 

-1> b-digit(X0) 

b-digit(XI) 

Is 

X0 * <value: 0> 

XI * <value: 0> 

recognized by the concept? * no * 

X0.value = 0 
XI.vaIue * 1 

Show me an example of lessd: * no * 

Description of lessd is: 

[X0, XI: 

X0.value * 0 
XI.value « 1 

] 

Learnt in 0.13 secs 

Do you want to teach me another concept? * yes * 
What is the name of the concept? * lessn * 

Show me an example of lessn: * (one,two) * 

Testing: 


1> 

X0 

.left * 

nil 

1> 

X0 

.right = 

■ X2 

1> 

X2 

.value - 

» 1 


XI 

.left * 

X0 


XI 

.right * 

■ X3 


X3 

.value = 

• 0 


b-i 

num(X0) 



X0 * cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0» 

XI = cleft: cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0»; right: cvalue: 0» 

recognized by the concept? * yes * 

Testing: 


1> 

X0.left - nil 

1> 

X0.right = X2 

1> 

X2.value - 1 


XI.left =■ X0 


XI.right - X3 

1> 

X3.value = 0 


b-num(X0) 


b-diglt(X3) 


Is 

X0 - cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0» 

XI « cleft: cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0»; right: cvalue: 1» 

recognized by the concept? * yes * 

Testing: 

1> X0.left - nil 

1> X0.right - X2 

1> X2.value - 1 

1> XI.left - X0 

1> XI.right - X3 

1> X3.value ■ 0 

b-num(X0) 

1> b-digit(X3) 

b-num(X1) 

Is 

X0 - cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0» 

XI - cleft: nil; right: cvalue: 1» 

recognized by the concept? * no * 

XI.left - X0 
XI.right - X3 
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b-num(X0) 
b-diglt(X3) 

Show me on example of lessn: * (two,three) * 

Test Ing: 

X0.left - X2 
1> X2.left - nil 

1> X2.right - X3 

X3.value - 1 
X0.right - X4 
X4.value ■ 0 
XI. left - X2 
XI.right - X3 
b-num(X2) 

Is 

X0 * < I e f t: < I e f t: <left: nil; right: <value: 1»; right: <value: 0»; right: <value: 0» 

XI ■ < I e f t: <left: < I e f t: nil; right: <value: 1»; right: <value: 0»; right: <value: 1» 

recognized by the concept? * yes * 

Testing: 

X0.left « X2 
1> X2.left - nil 

1> X2.right - X3 

1> X3.value ■ 1 

X0.right - X4 
X4.value - 0 
XI. left - X2 
XI.right - X3 
b-num(X2) 
b-digIt(X3) 

Is 

X0 = < I ef t: < I ef t: < I ef t; nil; right: <value: 1»; right: <value: 1»; right: cvalue: 0» 

XI - < I ef t: < I ef t: < I ef t: nil; right: cvalue: 1»; right: cvalue: 1»; right: cvalue: 0» 

recognized by the concept? * no * 

Testing: 

X0.left - X2 
1> X2.left - nil 

1> X2.right * X3 

1> X3.value - 1 

X0.right « X4 
1> X4.value * 0 

XI.left » X2 
XI.right - X3 
b-num(X2) 
b-digit(X3) 

Iessd(X4, X3) 

Is 

X0 « cleft: Cleft: cleft: nil; right: cvalue: 1»; right: Cvalue: 0»; right: cvalue: 0» 

XI * cleft: cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0»; right: cvalue: 1» 

recognized by the concept? * yes * 

Testing: 

X0.left = X2 
1> X2.left - nil 

1> X2.right = X3 

1> X3.value * 1 

X0.right = X4 
1> X4.value = 0 

1> XI.left = X2 

1> XI.right * X3 

b-num(X2) 

1> b-digit(X3) 

Iessd(X4, X3) 
b-num(X1) 

Is 

X0 * cleft: cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0»; right: cvalue: 0» 

XI = cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0» 

recognized by the concept? * no * 

Testing: 


1> 

X0.left = 
X2.left = 

X2 
n i 1 

1> 

X2.right 

= X3 

1> 

X3.va1ue 

= 1 

1> 

X0.right 
X4.va1ue 

= X4 
= 0 

2> 

XI.left = 

X2 
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2> XI.right * X3 

1> b-num(X2) 

1> b-digit(X3) 

lessd(X4, X3) 
b-num(X1) 
lessn(X2, XI) 

Is 

X0 - < | ef t: <1 eft: < I ef t: nil; right: cvalue: 1»; right: <value: 0»; right: <value: 0» 

XI = < I ef t: < I ef t: nil; right: cvalue: 1»; right: <value: 1» 

recognized by the concept? * no * 

Iessn(X2, XI) 

Testing: 

X0.left * X2 
1> X2.left = niI 

1> X2.right = X3 

1> X3.value = 1 

X0.right = X4 
1> X4.value = 0 

2> XI.left * X2 

1> XI.right = X3 

1> b-num(X2) 

2> b-digit(X3) 

lessd(X4, X3) 
b-num(X1) 

Iessn(X2, XI) 

I s 

X0 « <| ef t: < I ef t: < I ef t: nil; right: <value: 1»; right: <value: 0»; right: <value: 0» 

XI = <1 ef t: < I ef t: nil; right: cvalue: 1»; right: cvalue: 1» 

recognized by the concept? * no * 
lessn(X2, XI) 

Test Ing: 

X0.left * X2 
1> X2.left - nlI 

1> X2.right - X3 

1> X3.value ■ 1 

X0.right - X4 
1> X4.value « 0 

1> XI.left - X2 

2> XI.rIght * X3 

1> b-num(X2) 

2> b-digit(X3) 

Iessd(X4, X3) 
b-num(X1) 

Iessn(X2, XI) 

Is 

X0 = cleft: cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0»; right: cvalue: 0» 

XI = cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 1» 

recognized by the concept? * no * 
lessn(X2, XI) 

Testing: 

X0.left - X2 
1> X2.left = niI 

1> X2.right = X3 

1> X3.value * 1 

X0.right « X4 
1> X4.value - 0 

1> XI.left = X2 

1> XI.right * X3 

1> b-num(X2) 

1> b-digit(X3) 

I essd(X4, X3) 

-1> b-num(XI) 

lessn(X2, XI) 

I s 

X0 » < I ef t: <1 ef t: cleft: nil; right: cvalue: 1»; right: cvalue: 0»; right: cvalue: 0» 
XI - cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 1» 


recognized by the concept? * no * 

X0.left » X2 
X0.right - X4 
XI.left » X2 
XI.right - X3 

( continued ) 


BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER 1986 403 



November 


b-num(X2) 

I«ssd(X4, X3) 

Show me an example of lessn: * (one,four) * 

Test Ing: 

1> X0.left - niI 

1> X0.right - X2 

1> X2.value ■ 1 

XI.left - X3 
X3.left - X0 
X3.right - X4 
X4.value ■ 0 
XI.right - X4 
b-num(X0) 

Is 

X0 = < I e f t: < I e f t: nil; right: <value: 1»; right: <value: 0» 

XI = < I e f t: < I e f t: deft: deft: nil; right: cvalue: 1»; right: <value: 0»; 

right: cvalue: 0»; right: cvalue: 

recognized by the concept? * yes * 

Testing: 

1> X0.left - niI 

1> X0.right = X2 

1> X2.value * 1 

XI. left =» X3 
X3.left * X0 
X3.right * X4 
1> X4.value = 0 

XI.right - X4 
b-num(X0) 
b-digit(X4) 

Is 

X0 « cleft: Cleft: nil; right: cvalue: 1»; right: cvalue: 0» 

XI * cleft: cleft: cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0»; 
right: cvalue: 1»; right: cvalue: 

recognized by the concept? * yes * 

Testing: 

1> X0.left - niI 

1> X0.right = X2 

1> X2.value ■ 1 

XI.left - X3 
1> X3.left = X0 

1> X3.right = X4 

1> X4.value * 0 

XI.right - X4 
b-num(X0) 
b-digit(X4) 
b-num(X3) 

Is 

X0 = cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0» 

XI = cleft: cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0»; right: cvalue: 1» 

recognized by the concept? * yes * 

Testing: 

1> X0.left = nil 

1> X0.right * X2 

1> X2.value = 1 

XI.left = X3 
2> X3.left * X0 

2> X3.right = X4 

1> X4.value = 0 

XI.right = X4 

1> b-num(X0) 

b-dlglt(X4) 
b-num(X3) 
lessn(X0, X3) 

Is 

X0 » cleft: nil; right: cvalue: 1» 

XI = cleft: cleft: cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0»; 
right: cvalue: 0»; right: cvalue: 


recognized by the concept? * yes * 
Testing: 

1> X0.left = nil 
1> X0.right = X2 
1> X2.value = 1 
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1> XI.left = X3 

2> X3.left - X0 

2 > X3.right = X4 

1> X4.value » 0 

1> XI.right - X4 

1> b-num(X0) 

1> b—<J I g 11 (X4) 

1> b-num(X3) 

lessn(X0, X3) 
b-num(X1) 

Is 

X0 * <1 eft: <1 eft: nil; right: cvalue: 1»; right: <value: 0» 
XI = <Ieft: nil; right: <value: 1» 


recogn i 

zed by the concept? 

count = 
Testing 

1 length =* 2 

1> 

X0.left = nil 

1> 

X0.right * X2 

1> 

X2.value * 1 

2> 

XI. left * X3 

2> 

X3.left * X0 

2> 

X3.right * X4 

1> 

X4.value - 0 

2> 

XI.right = X4 

1> 

b-num(X0) 

1> 

b-digit(X4) 

2> 

b-num(X3) 
lessn(X0, X3) 
b-num(X1) 
lessn(X3, XI) 


Is 

X0 « < I ef t: <1 ef t: nil; right: cvalue: 1»; right: cvalue: 0» 

XI - cleft: cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 1»; right: cvalue: 0» 


recognized by the concept? * yes * 

Iessn(X0, X3) 

Iessn(X3, XI) 

Show me an example of lessn: * no * 
Description of lessn is: 

[X0. XI: 

[E X2, X3: 

XI.left - X0 
XI.right - X3 
b-num(X0) 
b-digit(X3) 

] 


OR 


[E X2, X3, X4: 

X0. left =■ X2 


X0.right - X4 
XI.left = X2 
XI.right - X3 
b-num(X2) 
lessd(X4, X3) 

] 

OR 

[E X2, X3, X4: 

Iessn(X0, X3) 

Iessn(X3, XI) 

] 

•** MARVIN has formed three rules about 
*** than for binary numbers. 


I ess- 


£$j|| 

*** 1) X0 is less-thon XI if XI con be split 
*** so that It has X0 as Its most slgnifl- 

*** digits and It has one extra, eg. 

**« 1 c 10 c- (1) c (1) + 0 


£££ 

*** 2) X0 is less-thon XI if XI has the same 
*** most significant digits os X0 and the 
*** least significant digit of X0 is less 
*** than (lessd) that of XI. eg. 

«** 10 C 11 C- (1)+0 C (1)+1, 


*♦* 
*** 
*** 
*** 
♦ ♦♦ 

*** 

*** 

* + * 


( continued ) 
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*** 

0 

c 1. 

*** 

*** 



*** 

*** 

3) X0 is less than XI 

if there is a 

*** 

*** 

binary number, X3, 

that X0 is less- 

*** 

*** 

than, and In turn 

is 1ess-than XI. eg. 

*** 

♦ ** 

1 C 100 c- 

*** 

*** 

1 essn 

(1.10), by ru1e 1 

*** 

* ** 

1 essn 

(10,100), also 

*** 

*** 


by rule 1 

*** 

*** 

Note that rule 3 Is applied recursively 

*** 

*** 

until either rule 1 or rule 2 may be 

*** 

*** 

applied. 


*** 

*** 



*** 


Learnt In 6.07 secs 

Do you want to teach me another concept? * yes * 

What Is the name of the concept? * greatn * 

Show me an example of greatn: * (two,one) * 

Testing: 

X0.left - XI 
X0.right » X2 
1> X2.value * 0 

XI. left =» nl I 
XI.right * X3 
X3.value » 1 
b-digit(X2) 

Is 

X0 ■ <Ieft: <Ieft: nil; right: cvalue: 1»; right: cvalue: 1» 
XI = <Ieft: nil; right: cvalue: 1» 

recognized by the concept? * yes * 

Testing: 



X0 

.left = 

XI 


X0 

.right = 

X2 

1> 

X2 

.value = 

0 

1> 

XI 

.left * 

nil 

1> 

XI 

.right = 

X3 

1> 

X3 

.value = 

1 


b- 

digit(X2) 


b- 

num(X1) 



Is 

X0 = cleft: cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0»; right: cvalue: 1» 
XI = cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0» 

recognized by the concept? * yes * 


Testing 


1> 

X0.left = XI 

1> 

X0.right - X2 

1> 

X2.value - 0 

1> 

XI.left « ni1 

1> 

XI.right - X3 

1> 

X3.value =» 1 

1> 

b-digit(X2) 
b-numfXI ) 
b-num(X0) 


Is 

X0 « cleft: nil; right: cvalue: 1» 

XI = cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0» 
recognized by the concept? * no * 


Testing 


2> 

X0.left = XI 

2> 

X0.right = X2 

1> 

X2.va1ue « 0 

1> 

XI.left - nil 

1> 

XI.right = X3 

1> 

X3.value = 1 

1> 

b-digit(X2) 

1> 

b-num(X1) 


b-num(X0) 

1essn(X1, X0) 


Is 


X0 ® cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 1» 
XI ■ cleft: cleft: nil; right: cvalue: 1»; right: cvalue: 0» 

recognized by the concept? * yes * 

Iessn(X1, X0) 
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Show me on example of greatn: 
Description of greatn is: 

[X0, XI: 

[E X2, X3: 

Iessn(X1, X0) 

] 


] 


* no * 


Learnt in 0.65 secs 

Do you want to teach me another concept? * no * 
End of run 


CARDS.BAS 

Mathematical Recreations: "Paradoxes of Probability," 
by Robert Kuroasaka, November 1986, page 373. 


10 PRINT "Given D decks, each containing N cards," 

20 PRINT "this program calculates the probability" 

30 PRINT "of finding at least two identical cards" 

40 PRINT "among the top C cards of each deck." 

50 PRINT 

60 INPUT "How many decks (>1)";D 
70 IF D<1 THEN END 

80 INPUT "How many cards in each deck (>0)";N 
90 IF N<1 THEN END 

100 PRINT "Draw how many cards from each deck (1-";N;")"s 
110 INPUT C 

120 IF C<1 OR C>N THEN END 

130 PRINT “Successive chances for NOT matching..." 

140 P-1 

150 FOR J-1 TO D-1 
160 FOR 1-1 TO C 
170 X«N+1-J*C-I 

190 print'using ••### / m ‘ #•#####";X.Y.X/Y 
200 P«P*X/Y 

210 IF P-0 THEN I-C: J-D-1 
220 NEXT I.J 

230 PRINT "Cumulative probability of a MATCH-";1-P 


MATCHES.BAS 

Mathematical Recreations: "Paradoxes of Probability." 
by Robert Kuroasaka, November 1986, page 373. 


10 0K-.99999 :REM Close enough to 1 

20 PRINT "Calculate the probabilities for finding a match," 

30 PRINT "given C possible outcomes and taking N events." / 

40 INPUT "Enter value for C (>1)";C 
50 IF C<2 THEN PRINT "Can’t be.": END 

60 PRINT "Enter a starting value for N, from 2 to ";C-1; 

70 INPUT SV 

80 IF SV<2 OR SV>-C THEN PRINT "Can’t be.":END 

90 PRINT "Table of probabilities given ";C;"possible outcomes." 
100 PRINT "# of events Probability" 

n 0 fm$- mm #.######■• 

120 FOR N-SV TO C-1 
130 P-1 

140 FOR J-1 TO N-1 STEP 1 
150 P-P*(C-J)/C 
160 NEXT J 

170 PRINT USING FM$;N.1-P 
180 IF 1-P>-0K THEN N-C-1 
190 NEXT N 


(amtinurd) 
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HCLASS.PAS 

"Predicting International Events," by Philip A. 
Schrodt, November 1986, page 177. 


Program Ho I I and; 

(* Ho I I and cI asslf1er 
Classifier codes: 

2 — Feature present 
1 — Ambiguous (pass-through) 
0 — Feature absent 

(C) 1986, Phi I ip A. Schrodt 

All rights reserved 

Author: Philip A. Schrodt 

Dept of Political Science 
Northwestern University 
Evanston, IL 60201 
312-491-2642 

History: 

Apple II Pascal version 86.3 

Turbo 3.0 Pascal version 86.9 

*) 


Const 

Hist_Size«1000; 
N_Feature-20; 
TwoN_Feature»40; 
N_RuIes= 32; 
Board_Size=4; 
SLabel_SIze-10; 

Stats_Slze»200; 

N_Stats*3; 


Recomb_Line=9; 
Mutate_Line«10; 
Bel 1-7; 

ESC-27; 

BackSpace=8; 

CR-13; 

Space-32; 

RuIe_Len=40; 


* Lower bd on size of InHist file *) 

* Number of features In message *) 

* 2*N_Feature *) 

* # of rules *) 

* # messages board holds *) 

* Size of array holding run label *) 

(* Size of array saving statistics *) 
(* # statistics recorded *) 


(* Assorted consts used in rule editor *) 


TYPE 

AMessage- Array[1..N.Feature] of integer; 

ARule- Array[1..TwoN_Feature] of integer; 

Str80 = string[80]; 

TMessage- Record 

Feature:AMessage; 

F rom:integer; 
end; 

TRule- Record 

CI assif,Messg:AMessage; 
Age,Win,RStrength:integer; 
end; 

TBid- Record 

BVaIue,Bidder,MatchM:integer; 
end; 


VAR 

RuIe:Array[0..N_RuIes] of TRule; 

Board: Array[1..Board_Size] of TMessage; 
High_Bid:Array[1..Board_Size] of TBid; 
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Obsrvd.Target:AMessage; 

K — Eon,M,Bid,K_Board,Iter:integer; 

SR,SO:real; (* sum of success ratios *) 

K_RuIes,K_RepI ace,KO,K_Stats,K_Reward:integer; 

Stats:array[1..Stats_Size,1..N_Stats] of real; 

N_Eons,New_Strength,Iter_Limit.Mutation_Prob,Match_Minimum.Eon_Length:integer; 
Bid_Adjust, Extinct_Prop,Reward_Adjust:reaI; 

T_SampIe,T_ShuffIe.Debug_LeveI:integer; 

Quiet,Reset_Strength,Finished,Good_Bid:boolean; 

OutSuffix,OutName:str80; 

K_Hist:integer; 

N_LabeI:integer; 

SLabeI:array[1..SLabeI_Size] of Str80; 

kE.ka.kb:integer; 
c,beep:char; 

Spec,Stren:reaI; 

InArch,Pr;Text; 

Procedure Quit;forward; 

\ NOTE ON AN ALTERNATIVE DATA STORAGE SCHEME 

In the production version of this program, the archives were stored in an 
array of 5 16-bit integers, then the 4-bit field indicating the lag was 
appended in the program. This reduces the storage requirement 
considerably. The code for expanding these is given below. 

The THist records were generated by a series of other programs which 
processed the raw COPDAB events data into archive form. 


TYPE 

THist* Record 

HArch: Array[1..5] of integer; 

HDyad:integer; 
end; 

Procedure Expand_Arch(I,Iag:integer;Var M:AMessage); 

(* Expands 16:bit I into M[1..16J. Lags are handled in M[17..20] as 
foilows: 

Lag 1..4 : Enter in binary 
5 : Enter $F 
*) 

Var ka:lnteger; 

BTran:packed array[1..16] of boolean; 
beg i n 

MoveLeft(I,BTran,2); 

for ka:«1 to 16 do if BTran[ka] then M[kal:*2 

eIse M[kaJ:*0; 

for ka:-17 to 20 do M[ka]:*0; 

Case lag of 
1;M[20l:-2; 

2:M[19J:»2; 

3:begin 



end; 

4:M[18]:*2; 

5; for ka:«17 to 20 do M[ka]:*2; 
end; (* case lag *) 
end; (* Expand_Arch *) 

} 

(«*** PRINTING PROCEDURES **♦*) 

Procedure WriteMess(M:AMessage): 

(* writes M In [1,*,0] format *) 

var ka;Integer; 

begin 

for ka:«1 to N_Feature do Case M[ka] of 


[continued] 


BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER 1986 409 





November 


end; (* WrIteMess *) 


0:write(pr, *0*) 
1:wri te(pr,* * *) 
2:wrltt(pr, T) 
end; (* case *) 


Procedure Dump_Rules; 

(* Dumps rules to disk *) 
var ka;Integer; 

S:str80; 

begin 

Cl osefpr); 

Write(*Enter file name for writing rules ->*); 

Read I n(S); 

Assignor ,S); 

ReWrlte(pr); 

Wr i te(*Wr111ng rules*); 
for ka:=1 to N_Rules do 
with Rule[ka] do begin 

Write(*.*); 

WriteMess(CIass If); 
wr Ite(pr,* ; ’); 

WriteMess(Messg); 

writeIn(pr,* *,RStrength;6,Win;6,Age:6); 

end; 

Wr Iteln(pr); 

Wr iteln; 

Close(pr); 

Assign(pr,’CON*); 

ReWrite(pr); 
end; (* Dump_Rules *) 


Procedure WrIteRuIe(kRuIe:integer;DetaiI:booIean); 
(* Prints rule ka *) 
var ka:integer; 
beg i n 

wr 11e(pr,kRuIe:3,* *); 

with Rule[kRule] do begin 
If DetalI then begin 

Wr11eMess(CI ass if); 
wr Ite(pr,* | *); 

WriteMess(Messg); 
end; 

*,RStrength:6,Win:6,Age:6); 


end; 
end; (* 


wr iteIn(pr,* 
WriteRule *) 


Procedure WriteBoard; 

(* Write contents of message board and target *) 
var ka:integer; 
beg i n 

for ka:*1 to K_Board do begin 
wr I te(pr,ka:2,* *}; 

WriteMess(Board[ka].Feature); 

Writeln(pr,* *,Board[ka].From:4); 
end; 

Write(pr,* T *); 

Wr I teMess(Target); 

Wr i teIn(pr); 
end; (* WriteBoard *) 


(****♦ PATTERN MATCHING FUNCTIONS *♦***) 

Function Match(KruIe.Kmess:integer):integer; 

(* Match measure — pure Holland measure *) 
var ka,M:integer; 
beg I n 

M:*TwoN_Feature; 

for ka:®1 to N_Feature do 

if Abs(RuIe[KruIe].Cl assif[ka]-Board[KMess].Featurefka])*2 then 
M:=M - 2; 

Match:=M; 
end; 

Function Reward(Kmess:integer):integer; 

(* Reward for prediction measure *) 
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var ka,R:Integer; 

•:real; 

beg i n 

R:=N_Feature - 4; 

for ka:*1 to N_Feature do 

R:*R - Abs(Target[ka]-Board[KMess].Feature[ka]); 
Reward:«Round(Reward_AdJust * R); 

If Debug_LeveI>=3 then 
beg I n 

s:*(R/16.0); 

Write(pr,’Payoff: Rule ’,Board[KMess].From:4,• : ',(Reword_Adjust*R):6:2); 
Wrlteln(pr,’ [',8:5:3,']’); 

(* Record learning statistics *) 


SR:=SR + s; 

K_Rewa r d:=K_Rewa r d+1; 
end; 


end; (* Reward *) 


Function Specif(KruIe;integer):reaI; 

(* Computes the Holland specificity score *) 
var ka ,M:integer; 
beg i n 
M :=0; 

for ka:*1 to N_Feature do 

if Rule[KruIe].Classif[ka]<>1 then M:=M+1; 
Specif:*M/N_Feature; 
end; (* Specif *) 


(******* PREDICTION PROCEDURES *******) 

Function F_Mess(KMess:integer):boolean; 

(* Determines If message KMess is terminal (i.e. has $F code) *) 
var ka:integer; 
beg i n 

F_Mess:«true; 

for ka:*17 to 20 do if Board[Kmess].Feature[ka]<>2 then F_Mess:*f a Ise; 
end; (* F_Mess *) 


Procedure Read — Arch(var A:Amessage); 

(* Reads N_Feature chars from InArch, converts [1,*,0] 


var c:char; 

ka;integer; 
begin 

for ka:*1 to N_Feature do 
begin 

Read(InArch,c); 
if c in ['1\’0’ 


-.•I 


then 
Case c 
•V 
•*' 
’0 


of 
; A 
; A 
: A 


:-2 

:-1 

:-0 


end (* case *) 


e I se 

begin 

Wr iteln(beep.beep); 

Write In('ll legal character 
A[ka]:«1; 
end; 


end; 

end; (* Read_Arch *) 


format to integers *) 


',c,'found in input’); 


Procedure Get_Predlct; 

(* Get next sample, post messages, set target; do assorted bookkeeping 
Note that If EOF is hit, procedure resets the file InArch, which isn't 
much of an error trap...*) 
var ka,kb:integer; 

c:char; 
beg i n 

(* Read next archive record *) 


for kb:*1 to 4 do begin 

Read_Arch(Board[kb].Feature); 
Board[kb].From:«0; 


( continued ) 
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If kb-3 then Read In(InArch) (* No EOF check here *) 

else for ka:«1 to 3 do Read(InArch,c); 

end; 


Read_Arch(Target); 

Read InfInArch); 

If Eof(InArch) then begin 

Writelnfbeep.beep); 

Writeln(’EOF encountered on input file; file reset’); 
ReSet(InArch); 
end; 

for ka:«1 to N_Feature do if Target[ka]-2 then Obsrvd[ka]:«0bsrvd[ka]+1; 

K_Board:*Board_SIze; 

Finished:*false; 

Iter:«0; 

RuIe[0].RStrength:»0; (* trash can:reset avoids overflow *) 

end; (* Get_Predict *) 


Procedure Eval_Predict(KMess:integer); 

(* distributes reward to poster of F_Mess; updates board *) 
beg i n 

with Board[Kmess] do 

Rule[From].RStrength := RuIe[From].RStrength + Reward(KMess); 

(* remove message from board *) 

K_Board:«K_Board-1; 

while KMess <=» K_Board do begin 

Board[KMess]:«Board[KMess+1]; 

High_Bid[KMess]:«High_Bid[KMess+1]; 

|WriteIn(’Eva^Predict: K_Mess-',K_Mess:4); 
WriteKB ;\ 

KMess:«KMess+1; 
end; 

end; (* Eval_Predict *) 


Procedure Post_Message(KMess:Integer); 

(* Posts the high_bidded message and does the bucket brigade 
adjustments of strength. Messg-1 is a pass-through ★) 
var ka:integer; 
beg i n 

with High__Bid[Kmess] do 

with Board[KMess] do begin 


Ru l e 
Ru I e 
Ru I e 


From].RStrength :« RuIe[From].RStrength + BValue; 
Bidder].RStrength :« RuIe[Bidder].RStrength - BValue; 
Bidder].Win :« RuIe[Bidder].Win + 1; 


for ka;«1 to N_Feature do 

if Rule[Bidder].Messg[ka]<>1 then 

Feature[ka]:«RuIe[Bidder].Messgfka]; 

From:*Bidder; 
end; 

end; (* Post_Message *) 


Procedure ShuffIe; 

(* Shuffles the rules to randomize bidding order *) 
var M:TRule; 

N,ka,k1,k2:integer; 
beg i n 

N:*N_Rules div 2; 

for ka:*1 to N do begin 

kl:«Random(N_RuIes) + 1; 
k2:«Random(N_RuIes) + 1; 
if k1ok2 then begin 

M:*RuIe[k1]; 

RuIe[k1]:*RuIe[k 2]; 

RuIe[k2j:=M; 
end; 

end; 

end; (* Shuffle *) 

PROCEDURE CLEARSCREEN;(* BLANKS OUT SCREEN *) 

BEGIN ClrScr;END; 
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Procedure QBeep; 

(* Bell with quiet option *) 
beg i n 

If not Quiet then Write(Chr(BeI I)); 
end; 

Procedure ReodJJpper(var ch:char); 
beg i n 

Read(kbd.ch); 

Write(ch); 

if ch>'Z' then ch:=chr(ord(ch)-32); 
end; 

Function Yes(S:str80):booIean; 

(* Asks a question and returns True if answer is ’Y’ *) 
var c:char; 
beg i n 

Write(S,* (Y/N) ? -> '); 

ReadJJpper(c); 

If c* 'Q' then Quit; 

Wr i teIn; 

Yes:*(c»*Y*); 
end; 


(* *******t* CHANGE PARAMETER VALUES ******* *) 

PROCEDURE WRITE_Param; 

(* WRITES OUT CURRENT VALUES OF PARAMETERS *) 

BEGIN 

CLEARSCREEN; 

G0T0XY(9,1); 

WRITELNf '»> PARAMETER MENU «<*); 

Wr i teIn('Enter first letters of parameter to change'); 
Wr i teIn; 

Writ eIn('CLASSIFIER PARAMETERS'); 

GotoXY(1*5); 

Write(' Bid Adjustment'); 

GotoXY(31,5); 

Writeln(Bid_Adjust:10:3); 

Wrlte(' Reward Adjustment'); 

GotoXY(31,6); 

Write In(Reward_Adjust:10:3); 

Write(' Match Minimum'); 

GotoXY(31,7); 

Write I n(Match__Mi n i mum: 6) ; 

Write(* New Strength'); 

GotoXY(31,8); 

Write In(Newestrength:6); 

Wrlte(' Extinction Proportion'); 

GotoXY(31,9); 

WriteIn(Extinct_Prop;10:3); 

Write(* Mutation Probability'); 

GotoXY(31,10); 

Write In((Mutatlon_Prob/100.0):10:3); 

WriteIn; 

Writeln('TIMING PARAMETERS'); 

Write(' Eon Length*); 

GotoXY(31,13); 

WrIteIn(Eon_Length:6); 

Write(' Number of Eons’); 

GotoXY(31,14); 

WriteIn(N_Eons:6); 

Wrlte(* Sampling Interval'); 

GotoXY(31,15); 

Writeln(T_Sample:6); 

Write(' Shuffling Interval'); 

GotoXY(31,16); 

WrIteIn(T_Shuf fIe:6); 

Wrlte(' Iteration Limit'); 

GotoXY(31,17); 

WrIteIn(Iter_LImit:6); 

Write(' Debug LeveI'); 

GotoXY(31.18); 

Wr1teIn(Debug_LeveI:6); 


[continued) 
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GOTOXYQ, 21 );WRITELN('CHANGE PARAMETER —>-); 
WRITEINCQ to return to menu’); 

G0T0XY(23,21)j 
END; (* Wrlte_Porom *) 


PROCEDURE READPAR(VAR R:REAL;Y:INTEGER); 

BEGIN VES CURS ° R T ° (30,Y)t BLANKS OUT NUMBER. READS NEW reol VALUE *) 

G0T0XY(31,Y);WRITE(’ •)• 

G0T0XY(31,Y);READLN(R); 

GOTOXY(31,Y);Wrlte(r:10:3); 

G0T0XY(23.21); 

Wrlte(' '); 

GotoXY(23,21); 

END; 


PROCEDURE REAOPARI(VAR I:Integer;Y:INTEGER); 

BEGIN VES CURS ° R T ° (30 - Y >* BLANKS OUT NUMBER, READS NEW Integer VALUE *) 

G0T0XY(31,Y);WRITE(’ -)• 

G0T0XY(31.Y);READLN(I); 

G0T0XY(31,Y);Write(l:6); 

GOTOXY(23,21); 

WrIte(’ -) : 

GotoXY(23,21); 

END; 

PROCEDURE Pa r ame ter; 

(* CHANGES PARAMETER VALUES *) 
var chrchar; 
r: reaI; 

BEGIN 

WrIte_Param; 

REPEAT READ_Upper(CH); 

CASE CH OF 

*B *:ReadPar (Bld_Adjust,5); 

*R*:ReadPar(Reward_Adjust,6); 

'M*:beg f n 

ReadJJpper(Ch); 

Case Ch of 

*A *:ReadParI(Match_MInImum,7); 

*U*:begin 

ReadPar(r,10); 

Mutat fon_Prob:»trunc(r* 100 . 0 ); 
end; 

end; (* case *) 
end; 

* I *:ReadParI(Iter_Liml t,17); 

’ D':ReadParI(Debug_LeveI,18); 

*N*:begln 

Read_Upper(Ch); 

Case Ch of 

*E’:ReadParI(Newestrength,8); 

’U*:ReadParI(N_Eons,14); 
end; (* case *) 
end; 

'E*:begin 

ReadJJpper(Ch); 

Case Ch of 

:ReadPar(Extinct_Prop,9); 

*0*:ReadParI(Eon_Length,13); 
end; (* case *) 
end; 

*S *:begin 

Read_Upper(Ch); 

Case Ch of 

*A*:ReadParI(T_SampIe,15); 

*H*:ReadParI(T_Shuffle, 16 ); 
end; (* case *) 
end; 

END; (* CASE *) 

UNTIL CH-'Q*; 

ClearScreen; 

END; (* Parameter *) 
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(* *«*• RULE EDITOR PROCEDURES *** *) 

Procedure List_Rules; 

(* Lists rules on screen *) 
var ka,kb,kc:integer; 

c:char; 
beg i n 

ClearScreen; 

GotoXY(29,1); 

Wr i te( ’>» RULE LISTING «<’): 

GotoXY(1,3); 

Writeln(’No. Classifier Message Strg Wins 

kc:*0; 

repeat 

ka:*kc+1; 
kc:*ka+15; 

if kc>N_Rules then kc:-N_Rules; 

for kb:«ka to ka+15 do WriteRuIe(kb.true); 

Wr iteln; 

if kc<N_RuIes then begin 

Writeln(’<CR> for more rules; Q to return to menu 

ReadJJpper(c); 

if c =’Q* then Exit; 

GotoXY(1,4); 
end; 

until kc>«N_Rules; 

ClrEol; N 

Write(*<CR> to return to menu *); 

ReadJJpper(c); 
end; (* List_Rules *) 

Procedure WrIte_Sym(I:integer); 

(* Converts AR elements to appropriate symbols *) 
begin 

Case I of 

0:Wrltt(’0 9 ): 

1:WrIte( j; 

2:Wr!te(T); 

end; 

end; (* Write_Sym *) 

Procedure Wr i teAr (LI ne :i nteger ; ArI:ARuIe); 
var ka:integer; 
beg i n 

GotoXY(1,Line+1); 

for ka:*1 to Rule_Len do begin 

Write(* ’); 

Write_Sym(ArI[ka]); 
if ka-IsLFeature then Writeln; 
end; 

end; (♦ WriteAr *) 

Function Read.RuIe_No:integer; 

(* Reads a rule number, checking for bounds *) 

var I:integer ; 

begin 

ReadlnH); 

while (I<1) or (I>N_Rules) do begin 

Wr1te('Number must be between 1 and *.N_RuIes:3,*. Try again»>’); 
Read In(I); 
end; (* while *) 

Read_RuIe_No:*I; 
end; (* Read_Rule_No ♦) 

FUNCTION Edit_Mutate 
(Var Ar1:AruIe):INTEGER; 

(* Screen editor for point mutations on the rule stored in Arl *) 

VAR Cel I,CurL!ne,Loc,KA:INTEGER; 

C:char; 

BEGIN 

WrIteAr(Mutate_L1ne,Ar1); 

CurL1nei-Mutate.LIne+1; 

Loc:-1; 

Cell:■1; 


Age’); 


); 
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GotoXY(1,CurLin«); 

WriteC|'); 

GotoXY(Loc*2+1,CurLIne); 

WrIt«(’I•); 

GotoXY(Loc*2,CurIine); 

REPEAT 

READ(kbd.C); 
i f Ord(c)oCR then 

If C<«’ * then Case Ord(C) of 
Backspace: begin Cell:—Ce11—1; 

Loc:«Loc-1; 

if CeI I<1 then begin Cell:«1; 

Loc:*1; 

Qbeep; 

end 

e I se 

if CeI I<>N_Feature then 
beg i n 

GotoXY(Loc*2+3,CurLine); 

WriteC ’): 

GotoXY(Loc*2-1,CurLine); 

Write(’|'); 

GotoXY(Loc*2,CurLIne); 

end 
e I se 
beg i n 

GotoXY(3.CurLine); 

Wr ite(* ’); 

GotoXY(I.CurLine); 

WriteC *); 

CurLine:»CurLine-1; 

Loc:»RuIe_Len div 2; 

GotoXY(Loc*2+1,CurLine); 

Write('|*); 

GotoXY(Loc*2-1.CurLine); 

Write(*|’); 

GotoXY(Loc*2,CurLine); 
end; 

end; 

Space: begin Loc:»Loc+1; 

Cel I:«Cel1 + 1; 

if CeI I>RuIe_len then begin CeI I:*CeI 1-1; 

Loc:«Loc-1; 
Qbeep; 

end 

e I se 

if CeI I<>N_Feature+1 then 
beg i n 

GotoXY(Loc*2-3,CurLIne); 

Wr i t e(* *); 

GotoXY(Loc*2+1,CurL \ ne); 

Write(*I *)I 

GotoXY(Loc*2,CurLine); 

end 
e I se 
beg i n 

GotoXY(Loc*2-1.CurLine); 

Wr ite(* ’); 

GotoXY(Loc*2-3,CurLine); 

WriteC *); 

CurLine:«CurLine+1; 

Loc:-1; 

GotoXY(3,CurLine); 

Wr I te(•|'); 

GotoXY(1,CurLine); 

WriteCC); 

GotoXY(Loc*2,CurLine); 
end; 

end; 

end (* case *) 
else begin 

if c in [*1*,*0*,then 
begin 

Write(c); 

Case c of 
’1’:Ar1[CeIl]:-2; 
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'*•: 

Aril 

ron; 

|:«1; 

'0' : 

Arl| 

[cell. 

|:-0: 

end; 

(* 

Case 

c *) 

end 





e I se 

begin 

Wr ite(beep); 

GotoXY(Loc*2,CurLine); 

Write_Sym(Ar1[CeII]); 
end; 

GotoXY(Loc*2.CurLine); 

end; 

UNTIL (Ord(C)-CR) OR (Ord(C)-ESC); 

if Ord(c)«ESC then Edit_Mutate:«-1 else Edit_Mutate:*1; 
END; 


Procedure Mutate; 

Var ka,kb:integer; 
cichar; 

Rlrreal; 

R1,Rnew:integer; 

Arl:Arule; 
beg i n 

Cl earScreen; 

GotoXY(9,1); 

Wr i teIn( ’>» POINT MUTATION <«'): 
Wr 1 teIn; 

Write(’Enter number of rule:’); 

Rl:«Read_RuIe_No; 


Wr i teIn; 

Wr i teIn('Use space and backspace keys to move mutation 
WriteIn('Use <CR> to finish; <ESC> to cancel'); 


point; then type mutation’); 
transfer rule to Arl *) 


for ka:-1 to N_Feature do begin 

Ar1[ka]:«Rule[R1l.Classif[ka]; 

Ar1[N_Feature+ka]:«Rule[R1].Messg[ka]; 

end; 


ka:- Edit_Mutate(Ar1); 


1 f ka<0 then Exit; 


Repeat 

GotoXY(1,Mutate_Line+7); 

Write('Rep I ace which rule with this new rule? ->'); 
Rnew:«Read_RuIe_No; 

Write('Are you sure? (Y/N/Q(uit) ->'); 

Read_Upper(c); 
if c -’Q’ then Exit; 
unt1 I c -’Y’; 


for kb:-1 to N.Feature do RuI eTRnewl.CI assif[kb]:«Ar1[kb]; 

for kb:-1 to N_Feature do RuIe[RnewJ.Messg[kb]:-Ar1[kb+N_Feature]; 

Wr iteIn; 

Wr1te('Enter strength for rule ->'); Readln(RI); 
with RuIe[RNew] do begin 

RStrength Trunc(RI); 

Age:-0; 

Win:-0; 

end; (* with *) 

end; (* Mutate *) 


(**♦* RECOMBINATION PROCEDURES **♦*) 

Procedure Wr1te_Rcomb(Line:integer; Ar1,Ar2:ARuIe); 
var ka:integer; 
beg i n 

WriteAr(Line.Arl); 

WrIteAr(LIne+3,Ar2); 

GotoXY(1»LIne+7); 

for ka:-1 to RuIe — Len do begin 


(continued) 
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Wrlte_Sym(Ar2[ka]); 
if ka-N_Feature then Write(* | ’); 
, end; 

end; (* WrlteAr *) 

FUNCTION Edit_Recomb(Line:integer; Ar1,Ar2:ARuIe):INTEGER* 

(* Recombination screen editor *) 

VAR Split t CeI I,CurL1ne,Loc,KA,MAX,LEFT;INTEGER; 

Cichar; 


Procedure Write2(X;Integer;c;char); 

(* Writes c in x-position X on CurLine, CurLine+3 *) 
begin 

GotoXY(x+1.CurLine); 

Write(c); 

GotoXY(x+1,CurL1ne+3); 

Write(c); 

end; (* Wrlte_2 *) 


BEGIN 

Wrlte_RComb(Recomb_Line,Ar1,Ar2); 

Split:«Rule_Len div 2; 

CurLine:«Line+1; 

Loc:-1; 

Cel I:«1; 

WrIte2(0,*|'); 

REPEAT 

READ(kbd.C); 

if C>’ • then Write(Chr(BeI I)); 
if Ord(C)oCR then 
Case Ord(C) of 

Backspace; begin CeI I;«CeI 1-1; 

Loc:»Loc-1; 

If CeI I<1 then begin Cell:«1; 

Loc:*1; 

Qbeep; 

end 

e I se 

if Cell<>SpIit then 
begin 

Write2(Loc*2,* *); 

Wr!te2(Loc*2-2 .*|*); 
end 
e I se 
begin 

Write2(0,* *); 

CurLine:*CurLine-1; 

Loc:»Split; 

Write2(Loc*2-2,*|»); 
end; 

If CeI I<-SpI 11 then GotoXY(CelI,Line+7) 

else GotoXY(Cell+3,LIne+7); 
WrIte_Sym(Ar2[CeI I]); 

WrIte(Chr(Backspace)); 

end; 


Space; 


begin Loc:*Loc+1; 

Cel I:*CeI 1 + 1; 

if CeI I>RuIe_Len then begin CeI I:=Ce11-1; 

Loc:=Loc-1; 
Qbeep; 
end 


e I se 

if CeI I<>SpIit + 1 then 
beg i n 

Write2(Loc*2-4,* •); 

Write2(Loc*2-2,'|’); 

end 
e I se 
begin 

Write2(Loc*2-4,* ’); 

CurLine;*CurLine+1; 

Loc:*1; 

Write2(0,*|*); 
end; 

if CeI I<»SpI 11 + 1 then GotoXY(Cel1-1,Line+7) 
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else GotoXY(Cell+2,Line+7); 
Wr i te_Sym(Ar 1[CeI 1-1]); 

Write(Chr(Backspace)); 

end; 

end (* case *) 

UNTIL (0rd(C)»13) OR (Ord(C)=ESC); 

if Ord(c)=ESC then Edit_ReComb:=-1 else Edit_ReComb:=Ce11; 
END; 


Procedure ReComb; 

(* Manual recombination of two rules *) 
var Rnew.RI,R2,ka,kb:integer; 
c:char; 

Rl:reaI; 

Ar1,Ar2:Arule; 
begin 

ClearScreen; 

GotoXY(9,1); 

Wr I te I n( ’»> RULE RECOMBINATION «<’); 
Writeln; . 

Write(’Enter number of first rule:’); 
Rl:-Read_RuIe_No; 

Write(’Enter number of second rule:'); 
R2:*Read_RuIe_No; 


Writeln; 
Wr i teIn(' 
Wr i teIn C * 
Writeln; 


Use space and backspace keys to select crossover point*); 

<CR> to fix crossover; <ESC> to cancel recombination’); 

(* transfer rules to Arl, 


for ka:*1 to N_Feature do begin 

Ar 1 [kal:»Ru I e[R1 ] .Classif[ka] ; 

Ar2[ka]:«Rule[R2].Cl asslf[ka]; 
end; 

for ka:«1 to N_Feature do begin 

Ar1[N_Feature+kal:*Rule[Rll.Messg[kal; 
Ar2[N_Feature+kaJ:«Rule[R2].Messg[kaJ; 

end; 


Ar2 *) 


ka:■ Edit_Recomb(Recomb_Line,Ar1,Ar2); 


if ka<0 then Exit; 


Repeat 

GotoXY(1,Recomb_Line+11); 

Write('Rep I ace which rule with this new rule? ->’); 
Rnew:*Read_RuIe_No; 

Qbeep; 

Write('Are you sure? (Y/N/Q(uit) ->*); 
ReadJJpper(c); 

Writeln; 

if c «'Q' then Exit; 
until c «'Y'; 


if ka<«N_Feature then 
beg i n 

for kb;«1 to ka do Ru I e[Rnew] .CI assif[kb]:-Ar1[kb]; 

for kb:»ka+1 to N_Feature do RuIe[Rnew].CIossif[kb]:*Ar2[kb]; 

for kb:«1 to N^Feature do Ru I e[Rnew] .Messg[kb] :®Ar2[kb+N_Feature]; 


end 
e I se 

b69 for kb:«1 to N.Feature do RuIe[Rnew].CI assif[kb]:=Ar1[kb]; 

for kb:*N_Feature+1 to ka do RuIe[Rnew].Messg[kb-N_Feature]:«Ar1[kbJ; 
for kb;-(ka-N.Feature) to N_Feature ^ A . 

V do RuIe[Rnew].Messg[kb];*Ar2[kb+N - Feature]; 


end; 


Wr1te('Enter strength for rule ->' 
with RuIe[RNew] do begin 

RStrength 

Age:«0; 

Win:-0; 

end; (* with *) 


); Read In(RI); 
Trunc(RI); 


(continued) 
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end; (* ReComb *) 


Procedure Modify; 

(* M(od!fy menu routine *) 
vor c:chor; 
begin 
Repeat 

ClearScreen; 

WrIt*(' L(!st, R(ecombine, M(utote, P(orom«ter8, C(ontlnu« -> ')• 
R«ad_Upp*r(e); 

Case c of 

*L*:LIst_Rules; 

*R*:Recomb; 

*M*:Mutate; 

'P*:Parameter; 
end; (* case c *); 
unt i I c«*C*; 
end; (* Modify *) 

(***** PRINTING PROCEDURES ****♦) 


Procedure Write_Record; 

(* Writes the Stats array *) 
var ka.kb:integer; 
beg i n 

Write(pr, *Nu I I 

for ka:«1 to N_Feature do if 
wr IteIn(pr); 


(Obsrvd[kaj/Ko)>0.5 then write(pr,* 1•) 
else write(pr,*0*); 


for ka:*1 to N_Feature-4 do write(pr,Obsrvd[ka]:5); 
wr iteIn(pr); 


Wr 1teInfpr); 

WriteIn(pr,’Success records by iteration (Ho I I and/statist1cal/repI aces V ) • 
for ka:-1 to K_Stats do begin 

Write(pr,(ka*T_SampIe+(Eon_Length*(K_Eon-1))):6); 
for kb:«1 to N_Stats do Write(pr.Stats[ka,kbl:8:3); 

Writeln(pr); J ' 

end; 

end; (* WriteRecord *) 


Procedure Write_HighBids; 

(* Just what It says.... *) 

var ka;integer; 

begin 

Writeln(pr); 

(* Writeln(*Msg Bid Match Rule - High bids -»).*) 

WrIteIn(pr,’Msg Bid Match Rule Stren Win Age*); 
for ka:«1 to K_Board do 
with High_Bid[ka] do 
If BValue>0 then begin 

Write(pr,ka:2,BVaIue:5,MatchM:5,• *); 

WriteRule(Bidder.false); 
end; 

end; (* Wr!teJHighBids *) 


Procedure PrintVars; 

(* Prints relevant variable values *) 
var s:str80; 
beg i n 

Writeln(pr); 

WrIteln(pr); 


for ka:«1 to N.Label do WriteIn(pr,SLabeI[ka]); 

WrIte(pr,*Match_Minimum «*,Match_Minimum:5); 
Writeln(pr,* Rewarded just =*,Reward_Adjust:7: 

WrIte(pr,*N_RuIes *', N_RuIes:5); 

Wr1teIn(pr,* Mutation_Prob **.Mutation_Prob:5); 
WrIte(pr,*TotaI samples «*,Ko:5); 

Wr iteIn(pr,* Eon «\K_Eon:5); 

Wr I te(pr,'Reset Strength «’); 

If Reset_Strength then wrItefpr,’True’) 
else write(pr,’False*); 

Writelnfpr,* Extinct.Prop «*.Extinct_Prop:5:2); 
Wr1teIn(pr,’New_Strength **.Newestrength:5); 
Wrlteln(pr); 
end; (* PrintVars *) 


2 ); 
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Procedure Quit; 

(* Exiting procedure *) 
var c:chor; 

^WH te( *Do you wish to write rules to a file? (Y/N/C(ance I) -> ); 
ReadJJpper(c); 

Writeln; 

if c«'Y* then Dump_Rules; 

If c-’C* then Exit; 

if Yes('Do you really want to quit*) then Halt; 
end; 


Procedure Print_Rules; 

(* Displays the rule set *) 
var c:char; 
begin 
Repeat 


Wr! te(^D(isplay, P(rlnt, M(odIfy. Continue. Q(uit? 
ReadJJpper(c); 

Writeln; 

Case c of 
*Q* -.Quit; 

*P*;begin 

Close(pr); 

Assign(pr,’LST*); 

ReWrite(pr); 

PrintVars; ^ N 

for ka:«1 to N_Rules do Wr i teRuIe(ka.true); 

Write_Record; 

Assign(pr,*Con *); 

ReWrite(pr); 
end; 

° ' bC9 for ka:-1 to N_Rules do WriteRuIe(ka,true); 
Write_Record; 

Writeln; 

end; 

•M’: Modify; 
end; (* case *) 

Until c«’C’; 
end; 


Procedure InltJYars; 

(* Initializes assorted variables *) 
var ka:Integer; 
c;char; 

beg i n 


ClearScreen; 

Writeln(' »> HOLLAND CLASSIFIER PROGRAM «< ); 

WriteIn(’ (C) 1986, Philip A. Schrodt’); 

WriteIn; 

Randomize; 

K_Eon:«0; 
beep:«Chr(Be II); 

Quiet:-false; (* Silence beep *) 


SR:«0.0; 

K_Stote:-0; 

K_Reword:=0; 

K_Replace:=0; 

SO:-0; 

KO:«N_Rulet; 


A8sign(pr,’CON’); 
ReWrlte(pr); 


(* Default output to CON *) 


for ka;-1 to N.Feature do Obsrvd[ka];-0; 


(* KEY VARIABLES: *) 


(continued) 
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BId_Adjust : = 0.125; 
Rewarded just :*2.00; 


(* Adjustment proportion for bid *) 

(* Adjustment multiplier for reward *) 


New_Strength:*128; 
Mutation_Prob:«30; 
Iter_Limit:» 5; 


(* Strength of new rules *) 

(* Mutation to * probability in new rules *) 
(* Bidding iteration IImit *) 


N_Eons:« 10; 
Eon_Length:«50 ; 
Match_Minimum:*36; 

Extinct_Prop:*0.5; 
Reset_Strength:*fa Ise; 


(* Number of eons *) 

(* Eon length *) 

(* Threshold for acceptable bids *) 

(* Proportion rules extinct at eon end *) 
(* Reset strength at end of eon? *) 


T__Samp I e :*10; 
T.Shuffle:*20; 
Debug_Level:-3; 


(* Sampling time for success record *) 

(* Shuffling interval *) 

(* This gives some control over the amount of 
screen output *) 


if Yes('Do you wish to set parameters ') then Parameter; 


N_LabeI :*0; 

If Yes(’Do you wish to set a printout label’) then begin 
Wrlteln; y 

WriteIn('Enter printout label (<CR> to stop)-’)- 
Repeat 

Wr i te( ’ >’); 


N_LabeI;»N_Labe1+1; 

Readln(SLabeI[N_LabeI]); 

Until ( L e n gth( s Lobe | [N_ Lab e | ])-0) or (N_Lobel>SLabel Size); 
if N_Label>Slabel_Size then WrIteIn(beep,’LabeI storage is 
end; 


ful 


end; (* InltVars *) 


Procedure Init.Rules; 

(* Initializes the rule base, then opens data base file *) 
var ka,ks:Integer; ' 

S:str80; 

begin 

Write('Enter rule base file name—>*); 

ReadlnfS); 

Assign(lnArch.S); 

ReSet(InArch); 

Wr i te('Reading rules'); 
for ka:*1 to N_Rules do 
with Rule[ka] do begin 

Write('.'); 

Read_Arch(CIass if); 

for ks:«1 to 3 do Read(InArch,c); 

Read_Arch(Messg); 

Read In(InArch,RStrength,Age,Win); 

(* Record observed features *) 
for ks:-1 to N_Feature do if Messg[ks]=2 then 

. , x Obsrvd[ks]:=0bsrvd[ks]+1; 

end; (* with *) J 

Close(InArch); 

Writeln; 

Wr i te('Enter data base file name—>'); 

Readln(S); 

Assign(InArch,S); 

ReSet(InArch); 

end; (* Init_Rules *) 


Procedure Reset_lnlt; 

(* Automatic reinitialization of variables, rules 
var ks,ka:integer; 
beg i n 


SR:*0.0; 
K_$tats:*0; 
K_Reward:=0; 
K_RepI ace:*0; 


I now. 
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end; (* Reset_Init *) 


Procedure ReplaceJ-ow; _ 

(* Replaces the weakest rule with a new rule based on InHist *; 

var ka,kb:integer; 

value,index:integer; 
begin 

vaIue:-RuIe[1].RStrength; 
index:»1; 

for ka:»2 to N.Rules do . . 

If Rule[ko].RStrength < value then begin pc, r . n „th- 

value:=RuI e[ka].RStrength, 

index:-ka; 
end: 


K_RepI ace:=K_RepIace+1; 
with RuIe[index] do begin 

ka:-Random(4) + 1; 

Cl ass If:»Boord[ko].Feature; 
Messg:«Torget; 


for kb:-1 to N_Feature do begin . 

if Random(100)<Mutation_Prob then Classif[kbj:«1 
if Random(100)<Mutation_Prob then Messg[kb]:«1; 
end; 


RStrength:«New_Strength; 

Age:-0; 

Win:=0; 

end; (* with *) 

Write(pr, 'Replacing rule *,index:3/ with ’); 
Wr iteRu I e(index,false); 
end; 


Procedure Record^Stats; 
(* Handles recording of 
var ka,P,Ro:integer; 
begin 

if kE mod T_Sample 


success statistics and some screen output *) 


0 then 

beg i n 

K_Stats:«K_Stats +1; . 

if K_Stats>Stats_Size then K_Stats:-Stats_Size; 


if 


K Reward>0 then Stats[K_Stats,11:=SR/k_l 
else Stats[K_Stats,1]:*0.0; 


Reward 


Stats[K_Stats 
Stats[K_Stats 
K_RepIace:-0; 
end; 


,2]:»SO/(ko-N_RuIes); 
,3]:«K_RepI ace; 


If (kE mod T_ShuffI e)*0 then Shuffle; 

Write(pr/Sample 9 t kE:A t 9 Eon ’.KLEon); 

,f K Wr!te(pr/ the Ave. success-’ ,(SR/K_Reward):5:2,’ .vs. 
Writeln(pr); 

(* Observational stats *) 

Ko:«Ko+1; 

Ro:*N_Feature - 4; 
writeln(pr); 

for ka:-1 to N_Feature do begin 

if (Obsrvd[ka]/Ko)>0.5 then P:-2 

else P:=0; 

if Target[ka]-P then wr ite(pr,’.') 

else wr i te(pr,*X’); 

Ro:«Ro - Abs(Target[ka]-P); 
end; 

SO:-SO + (Ro/16.0); v 

Wrlteln(pr,’ [*.(Ro/16.0):5:2,’] ); 

for ka:-1 to N_Rules do RuIe[ka].Age:-RuIe[ka].Age + 1; 
end; (* Record_Stats *) 


.(SO/(ko-N_Ru I es)) :5:2); 


{continued) 
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(*•***« EVOLUTION PROCEDURES ******) 
Procedure Evolve; 

(* Holland evolution procedures *) 
var kl, k2,ka,kb,N_Survive,K._Rules;Integer* 
Cross,One_Prob,No_Pass:integer; 


Procedure Sort.Rule; 

iar D M?TRu?e; er ° m ° tCheS * th#n bubbl « sort rul#s strength *) 

ka.kb:Integer; 
beg I n 

k 0: . 1; (* discord rules which haven’t matched *) 

Repeat 

^ ( ^K^Ru ifes:» k"ru ^es-^ ; 1 ® •Age>(Eon_Length div 2)) then begin 

end kt>: " k ° t0 K - Ru ' es do Ru I e[kb] :«Ru I e[kb+1 ] ; 
else ko:«ka+1; 

until (ka>K_Rules) or (K_Rules«N_Survlve); 

for ko:-1 to K_Rules-1 do 
for kb:«ka+1 to K_Rules do 

If RuIe[ko].RStrength < RuIe[kb].RStrength then begin 

M:»RuI e[ka]; 

RuIe[k a 1:=RuIe[k b]; 
RuIe[kb J:*M; 

end; (* Sort_Rule *) en ^* 

beg i n 

N_Survive : = Trunc(N_RuI es*(1.0-Extinet Prop)); 

K_Rules:«N_Rules; " 

Sort_RuIe; 

No_Pass:«0; ( * Colculate probability of 1’s *) 

One_Prob:«0; 

for ka;«1 to N_Survive do 

for kb:-1 to N_Feature do 
with RuIe[ka] do begin 

if CI assif[kb]=2 then One_Prob:*One_Prob + 1; 
if CI assif[kb]<>1 then No_Pass:*No_Pass + 1; 
if MessgTkbl-2 then One_Prob:=One_Prob + 1 * 
if Messgfkb Jol then No_Pass :=No_Pass + 1- 
end; ~ * 


^ I 

One_Prob:-Round(100*(One_Prob/No_Pass)); 


(* Recombination *) 

for ko:=N_Survive+1 to N_Rules do begin 
k1:«Random(N_Survive) + 1 ; 

Repeat k2:*Rondom(N_Survive) + 1 until k1ok2- 
Cross:=Random(TwoN_Feature- 1 ) + 1 ; 
if Cross<=N_Feature then 
begin 

l° r t0 C ' oss d0 Rule [ k °]-C | assif[kb]:=Rule[k1].CIassif[kb]: 

for kb:=Cross+1 to N_Feoture do 1 J ’ 

t RuIe[ka].Cl assif[kb]:=RuIe[k2l.Cl assiffkbl• 

end f ° r kb: = 1 to N ~Feature do RuIe[ka].Messgfkb]:-RuIe[k2].Messg[kb]; 

e I se 

beg i n 

Cross: =C r o s s - N__F e a t u r e; 
for kb:*1 to N_Feature do 

. .. . . . Rule[ka].CIossifrkbl:«Rule[k1].CIasslfrkbl- 

l° r to C !| oss d0 Ro 1 «[ka] .Messg[kbJ :=Ru I e[k1 J .Messgfkb] ; 

for kb:-Cross+1 to N.Feature do al J ’ 

#nd . RuIe[ka].Messgfkb]:=RuIe[k2].Messgfkb]; 


for kb:-1 to N_Feature do ( * Mu *° te the new rul « *> 

if Randomf100) < Mutation_Prob then 
with Rule[ka] do 

if Cl assif[kb]*1 then 
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if Random(100) < One_Prob then CI assif[kb]:=2 

else Cl assif[kb]:=0 


else Classif[kb]:=1; 


for kb: = 1 to N_Feature do 

if Random(100) < Mutation_Prob then 
with Rule[ka] do 

if Messg[kb]=1 then 

if Random(100) < One_Prob then Messg[kb]:=2 

else Messg[kb]:=0 

eIse Messg[kb]:*1; 

with Rule[ka] do begin 

RStrength:*New_Strength; 

Age:*0; 

Win:*0; 

end; 


end; (* for ka *) 


Writeln(pr); 

Wr i teIn(pr,*New rule set, Eon**,K_Eon:3); 
for ka : = 1 to N_Rules do Wr iteRuIe(ka,true); 
Write_Record; 


(* reset strength *) 


if Reset_Strength then 

for ka:=1 


to N_Survive do RuIe[ka].RStrength:=New_Strength; 


Shuffle; 

end; (* Evolve *) 

(♦** MAIN PROGRAM ***) 

beg i n 

Init_Vars; 

Init_RuIes; 

(* This code will divert output to a disk file 
rather than the consol 
Close(pr); 

Assign(pr,*testout.txt’) ; 

ReWrite(pr); 

*) 

if Debug_leveI >« 4 then Print_Rules; 

Repeat (* N_Eons loop *) 

K_Eon;«K_Eon+1; 

kE:-1; 

Repeat (* Eon.Length loop *) 

Get_Predict; 

Record.Stats; 

Wr i teIn(pr); 

Writeln(pr,’Initial Board:*); 

Wr iteBoard; 


Repeat 

for ka:*1 to K.Board do High_Bid[ka].BVaIue:*0; 
Write(pr,’Rule checking *); 
for ka:*1 to N_Rules do begin 


(* Main bidding loop *) 


wr i te(pr,*.'); 

Spec:-Speclf(ka); 

Stren:-Rule[ka].RStrength; 


[continued ) 
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for kb :*1 to K_Board do begin 
M:«Match(ka,kb); 

If M > Match_MinImum 

then Bid:»Round(BId_Adjust % Stren * Spec) 
else BId:*-1; 


jwr i te I n( 'RuI e ',ko:4,' Mesg ’.kb^.* 
Match-’,M:6,* Bid-’,BId:6);( 


If Bld>High_8id[kb].BValue then 

with Hlgh_Bid[kb] do begin 

BVolue:-Bid; 
BIdder:-ka; 
MatchM:«M; 

end; (* for K_Boord *) * n d. 

end; (* for N_Rules *) 


Wrlte_HighBids; 


Good_Bid:-false; ( * P ° 8t new messa 9 es 

for ka:« 1 to K — Board do 

if High_Bid[ka].BValue>0 then begin 

Post_Message(ka); 

Good_B id:=*true; 
end; 


*) 


if Good_Bid then 


(* Check for terminal 

beg i n 
ka:»1; 
repeat 

if F_Mess(ka) then Eval_Predict(ka) 
eIse ka:«ka+1: 


until ka>K_Board; 
end 

else begin 


if lter=0 then Replace_Low; 
Finished:*t rue; 
end; 


messages *) 


Iter:*Iter+1; 
if K_Board>0 then begin 

Writelnfpr); 

Writeln(pr,’Board ot Iteration \Iter:3); 

WrIteBoard; 
end; 

if (Iter>Iter_Llmft) or (K_Board=0) then Finished:-true; 

If (Debug_LeveI >=4) or KeyPressed then begin 

Reod(c); (* clear input *) 

Pr int__Ru I es ; 
end; 

untiI Finished; 
kE :*=kE+1; 

Until kE> Eon_Length; 

EvoIve; 

Reset_InIt; 

Until K__Eon>N_Eons; 

(* Close(pr,lock) use when diverting output *) 

Quit: 

end. 
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MAKERULE.PAS 

"Predicting International Events," by Philip A. 
Schrodt, November 1986, page 177. 


Program MakeRuIe; 

(* Creates rules out of HCLASS raw data 

This takes the first N.Rules records of a data file, randomly 
chooses one of the antecedent archives as a classifier, uses the 
consequent archive as a messages, and mutates [0,1] to * with 
probability Mutation_Prob 

A Strength, Age and Win record is concatenated onto the record, 
which is written in a format HCLASS can read. 

The input is a disk file; the output is another disk files with 
the letter 'R* added to the original file name. 

This is a quick utility program; no error checking to speak of 

(C) 1986, Philip A. Schrodt 
*) 


Const 

N_Feature=20; 

N_RuIes= 32; 

Mutation_Prob-30; 


* Number of features in message *) 

* # of rules *) 


TYPE 


SMessage- Array[1..N_Feature] of char; 


Classif:array[1..4] of SMessage; 
Messg:SMessage; 

Strength,Age,Win,ka,kb,ks;integer; 
c rchar; 

S:string[80]; 

Out Arch, InArch ‘.Text; 


Procedure Read_Arch(var A:Smessage); 

(* Reads N_Feature chars from InArch *) 
var c:char; 

ka:integer; 
begin 

for ka:»1 to N_Feature do 
begin 

Read(InArch,c); 

if c in [ * 1 * •'0*,***] then 

A[ka]:-C 

e I se 

begin 

WriteIn(* 11 legal character ’,c,’found in input*); 
A[ka]:-*0’; 
end; 

end; 

end; (* Read_Arch *) 
begin 

Strength:«128; 

Age:*0; 

Win:-0; 

Wr1te(’Enter InArch name—>*); 

Read In(S) ; 


[continued) 
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As$Ign(InArch,S); 

Reset(InArch): 

Insert('R',S,Pos( 

Assign(OutArch.S); 

RewrIte(OutArch); 

for ka:»1 to N_Rules do begin 
WrIte( ’.')j 

for kb:*1 to 4 do begin 

Reod_Arch(Classlf[kb]); 

If kb<>3 then for ks:»1 to 3 do Reod(InArch.c) 
else reodln(InArch); 

end; 

Read_Arch(Messg); 

Reodln(InArch); 

ks:»Rondom(4) + 1; 

for kb:«1 to N_Feature do 

if Random(100)<Mutation_Prob then Write(OutArch,) 

, v eIse Wr1te(OutArch,Class If[ks][kbl); 

WrIte(OutArch,* : •); Jl iJ 

for kb:«1 to N_Feature do 

If Random(100)<Mutotion_Prob then WrIte(OutArch,’*’) 

else WrIte(OutArch,Messg[kb]); 

Write In(OutArch,St rength:5,Age:5,Win:5); 
end; 

Close(OutArch); 
end. 


EUR0368.TXT 

"Predicting International Events," by Philip A. 
Schrodt, November 1986, page 177. 


00000000000000000001 
00000000010000000100 
00000000000000000001 
00000000000000000100 
00000000000100000001 
00000000000000000100 
00000100000000000001 
00000100000000000100 
00000000000000000001 
00001000000000000100 
00000000000000000001 
00000110000000000100 
00000000010000000001 
00000000000000000100 
00000000010000000001 
00000010000000000100 
00001000000000000001 
00000001100100000100 
00000000000000000001 
00000000000000000100 
00010011000000000001 
00000001000000000100 
00000000000000000001 
00001000000000000100 
00000001000000000001 
00000001000000000100 
00000000000000000001 
00000001000000000100 
00000000000000000001 
00000000000000000100 
00010111001000000001 
00000001000000000100 
00000000000000000001 
00000000001000000100 
00000000001000000001 
00000000001000000100 
00000001010000000001 


00000001000000000010 
00000111010000001111 
00000000010000000010 
00000111000000001111 
00000011010000000010 
00000000001000001111 
00000000000000000010 
00000000000000001111 
00000000000000000010 
00000000000000001111 
00000001010100000010 
00000001100000001111 
00000010000000000010 
00001000000000001111 
00000000000000000010 
00000111010000001111 
00000000000000000010 
00000001001000001111 
00000000000000000010 
00000000000000001111 
00100111000000000010 
00010101000000001111 
00000000000000000010 
00000001000000001111 
00010001000100000010 
00000001000000001111 
00010001000000000010 
00010000000000001111 
00000001000000000010 
00000101000000001111 
00000000000100000010 
00000111000000001111 
00000000000000000010 
00010100000000001111 
00000000000000000010 
00000000011000001111 
00011100001000000010 


00000001000000000011 
00000100000000000011 
00000000000000000011 
00000001000000000011 
00000000000000000011 
00000001000000000011 
00000000000000000011 
00000000000000000011 
00001000010000000011 
00000110000000000011 
00000000000000000011 
00000000000000000011 
00000001000000000011 
00000000100000000011 
00000100000000000011 
00100001000000000011 
00000000000000000011 
00000000001000000011 
00011101000000000011 
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00000001010000000100 : 
00000000000000000001 : 
00000001000000000100 : 
00000000000000000001 : 
00000100000000000100 : 
00001001000100000001 : 
00000000000000000100 : 
00000000000000000001 : 
00000000100000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00001000000100000100 : 
00010011000000000001 : 
00000000001000000100 : 
00000000111000000001 : 
00000001010000000100 : 
00100101000000000001 : 
00000000000000000100 : 
00000011000000000001 : 
00000100011000000100 : 
00000101000000000001 : 
00000000000000000100 : 
00000010000000000001 : 
00011111011000000100 : 
00000010001100000001 : 
00000001000000000100 : 
00010000000000000001 : 
00000011000000000100 : 
00000000001000000001 : 
00011000000000000100 : 
00000011000000000001 : 
00000001011000000100 : 
00000001000000000001 : 
00000000010000000100 : 
00000001000000000001 : 
00000101000000000100 : 
00000000000000000001 : 
00000001000000000100 : 
00000000000000000001 
00001000000000000100 
00000000001000000001 
00000000001000000100 
00000001000000000001 
00000101000000000100 
00000001000000000001 
00000000000000000100 
00000100000000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000000011000000001 
00000000000000000100 
00000101000000000001 
00000100000000000100 
00100000010000000001 
00000001010000000100 
00001010000000000001 
00010000000000000100 
00000000000000000001 
00000111000000000100 
00000000000000000001 
00011000000000000100 
00000000000000000001 
00000000010000000100 
00000001000000000001 
00000011000000000100 
00000000000100000001 
00000001010000000100 
00001000000000000001 
00000000000000000100 
00000010010000000001 
00000000000000000100 
00000000000000000001 
00000001000000000100 


00000111011000001111 
00000000000000000010 : 
00000111010000001111 
00000101000000000010 : 
00000101000000001111 
00000000000000000010 : 
00000010100000001111 
00000000000000000010 : 
00010000010000001111 
00000010000000000010 : 
00001000000000001111 
00000000100000000010 : 
00010000000100001111 
00000001010000000010 : 
00000000000100001111 
00000000000000000010 : 
00000000001000001111 
00000000000000000010 : 
00001000010000001111 
00001001001000000010 : 
00000111110000001111 
00000110010000000010 : 
00000001000000001111 
00000100001000000010 : 

, 00110111000100001111 
: 00000000010000000010 : 

: 00000000000000001111 
> 00000001000000000010 : 
: 00000011000000001111 
: 00000010001000000010 : 
: 00100011101100001111 
: 00000001000000000010 : 
: 00000000000000001111 
: 00000001000000000010 : 
: 00010010001000001111 
: 00000010011100000010 : 
: 00000001000000001111 
: 00000000000000000010 : 
: 00000111010000001111 
: 00000000000000000010 : 
: 00000001000000001111 
: 00000000000000000010 : 
: 00000000011000001111 
: 00000100001000000010 : 
: 00000001011000001111 
: 00000000000000000010 
: 00100100000000001111 
: 00000000000000000010 
: 00000000000000001111 
: 00000000000000000010 
: 00000000000000001111 
: 00000000000000000010 
: 00000000001000001111 
: 00000001010100000010 
: 00000001000000001111 
: 00000010000000000010 
: 00000111000000001111 
: 00000000000000000010 
: 00001000011000001111 
: 00000001000000000010 
: 00000111010000001111 
: 00000000000000000010 
: 00011000011000001111 
: 00000000000000000010 
: 00000100000000001111 
: 00100000000000000010 
: 00000010000000001111 
: 00000000000000000010 
: 00000101011000001111 
: 00000101000000000010 
: 00001000000000001111 
: 00000000001000000010 
: 00000100001000001111 
: 00000000000000000010 
: 00000100000000001111 


00000000000000000011 
00000101000000000011 
00001001010000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00100101000000000011 
00001000000000000011 
00000101000000000011 
00000100000000000011 
00001011011000000011 
00000101000000000011 
00100000000000000011 
: 00110001010000000011 
: 00000101000000000011 
: 00000000000100000011 
: 00000001000000000011 
: 00000000010000000011 
: 00001000000000000011 
: 00000000000000000011 
: 00000001011000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000001000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000010000000000011 
: 00000011000000000011 
: 00000011000000000011 
: 00001000000000000011 
: 00001000001000000011 
: 00001100000000000011 


(continual 
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00000000000000000001 
00010000000000000100 
00000000000000000001 
00000101010000000100 
00000001000000000001 
00000011000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00100000000000000100 
00000000010000000001 
00000000000000000100 
00000101000000000001 
00000100000000000100 
00000000000000000001 
00000011000000000100 
00000000100000000001 
00100001000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00001000000000000100 
00000000000000000001 
00000000001000000100 
00000000000000000001 
00000000010000000100 
00000000000000000001 
00001000000000000100 
00000010000000000001 
00000001000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000000001000000100 
00000001000000000001 
00000000000000000100 
00000001000000000001 
00000000000000000100 
00000000000000000001 
00000001000000000100 
00000000000000000001 
00000001000000000100 
00001010000000000001 
00000000000000000100 
00000000000000000001 
00000100000000000100 
00000000000000000001 
00000111000000000100 
00000000010000000001 
00000000000000000100 
00000001010000000001 
00001010011000000100 
00000000000000000001 
00000001000000000100 
00000000000000000001 
00010000000100000100 
00001000000000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000011010000000001 
00000000001100000100 
00000000000000000001 
00000101000000000100 
00000000000000000001 
00001000000000000100 
00000001000000000001 
00010000010000000100 
00000010000000000001 
00100000000000000100 
00000000000000000001 
00001101000100000100 
00000000010000000001 
00000000000000000100 
00000001000000000001 


000000000000000000 1 0 
00000100000000001111 
000000000000000000 1 0 
00001101000000001111 
00000010000000000010 
00000001000000001111 
000000000000000000 10 
00000000000000001111 
000000 1 00000000000 1 0 
00000011000000001111 
000000000000000000 1 0 
00000000000000001111 
00000100011000000010 
00000001000000001111 
00011001000000000010 
00000011001000001111 
000000000 1 00000000 1 0 
00000001000000001111 
000000000000000000 1 0 
00000000011100001111 
00000000000000000010 
00000100000000001111 
00011001000000000010 
00100100001000001111 
000000000000000000 1 0 
00000100000000001111 
00000000000000000010 
00000101000000001111 
00000110010000000010 
00001010000000001111 
00000101000000000010 
00000000000000001111 
000000000000000000 1 0 
00010000000000001111 
00000100000000000010 
00000000011000001111 
000000000000000000 1 0 
00000101010000001111 
00000 1 000000000000 1 0 
00000011010000001111 
000000000000000000 1 0 
00000010010000001111 
00000001000000000010 
00011001001000001111 
00000001100000000010 
00001010001100001111 
000000000000000000 1 0 
00000011011000001111 
00000 1 000000000000 1 0 
00000001000000001111 
00000001011000000010 
00000001001000001111 
00010001010000000010 
00000011011000001111 
00000101000000000010 
00000010000000001111 
00000000000000000010 
00001011000000001111 
000000000000000000 1 0 
00000110000100001111 
000000000000000000 1 0 
00000000011000001111 
0000000 1 0000000000 1 0 
00000001110000001111 
000000000000000000 1 0 
00000011010000001111 
00000001000000000010 
00011110010000001111 
00000111010000000010 
00001011011000001111 
00000001000000000010 
00000100000000001111 
00000011000000000010 
00000010010000001111 
00000100000000000010 
00001100000000001111 
00000000000000000010 


00000001000000000011 
00000100010000000011 
00000001010000000011 
00000000000000000011 
00000100000000000011 
00000000000000000011 
00000011110000000011 
000000000 1 0000000011 
00000000000000000011 
00000000000000000011 
00001001000000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00011001000000000011 
00000000000000000011 
00000000000100000011 
00000101000000000011 
00000001000000000011 
00001000000000000011 
00000000000000000011 
00000001000000000011 
00000100010000000011 
00000011000000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00000001011100000011 
00000100000000000011 
00000001001100000011 
00000001001000000011 
00000110000000000011 
000010100000000000 11 
00000000000000000011 
00000000000000000011 
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00000000000000000100 : 
00000100001000000001 : 
00000011010000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00100101010000000001 : 
00000001000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000100000000000001 
00000000010000000100 
00000000000000000001 
00000100000000000100 
00000010000000000001 
00000100000000000100 
00000000010000000001 
00000000000000000100 
00000111000000000001 
00100100000000000100 
00000101000000000001 
00000000000000000100 
00000010010000000001 
00001111000000000100 
00000001000000000001 
00000000000000000100 
00000011000000000001 
00001000000000000100 
00000001000000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000001000000000100 
00000000100000000001 
00000001000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000010000000000100 
00000000000000000001 
00000000000000000100 
00000001100000000001 
00000011010000000100 
00000100000000000001 
00000000010000000100 
00000001010000000001 
00000001000000000100 
00000000000100000001 
00000010000000000100 
00001000000000000001 
00000101000000000100 
00010000000000000001 
00000010011000000100 
00000000000000000001 
00000000000000000100 
00000011000000000001 
00011100001000000100 
00000010001000000001 
00000011000000000100 
00000001000000000001 
00000000001000000100 
00000011000000000001 
00000000000000000100 
00000100000000000001 
00000001000000000100 
00001001000000000001 
00000001000000000100 
00000010000000000001 
00000000000000000100 
00000000000000000001 
00000001000100000100 
00000001000000000001 
00000101000000000100 


00000001000000001111 
00000000000100000010 : 
00000000000000001111 
00000000000000000010 : 
00000001000000001111 
00000000000000000010 : 
00010101000000001111 
00000000001000000010 : 
00000000010000001111 
00000000001000000010 : 
00001101001100001111 
00000000000000000010 : 
00000000000000001111 
00100011000000000010 : 
00000001000000001111 
00000000000000000010 : 
00000000000000001111 
00100000000000000010 : 
00000001000000001111 
00000110000000000010 : 
00000001000000001111 
00001100000000000010 : 
00010000000000001111 
00010100000000000010 : 
00000000001000001111 
00000000000000000010 : 
00000111000000001111 
00000000000000000010 : 
00001101001000001111 
00000000000000000010 : 
00000101000000001111 
00000001000000000010 : 

; 00000000000000001111 
; 00000000000000000010 : 

; 00000001000000001111 
: 00000001000000000010 : 
: 00011001000000001111 
: 00000000000000000010 : 
: 00000110000000001111 
: 00000001010000000010 : 
: 00000000010000001111 
: 00000101011000000010 : 
: 00000101001000001111 
: 00000001000000000010 
: 00001011010000001111 
: 00001100001000000010 
: 00000010000000001111 
: 00000000000000000010 
: 00010111000000001111 
: 00000000000000000010 
: 00000000001000001111 
: 00000001000000000010 
: 00110001001000001111 
: 00000000001000000010 
: 00000010000000001111 
; 00000000000000000010 
: 00000001000000001111 
: 00000011010000000010 
: 00010110000100001111 
: 00000100000000000010 
: 00000001000000001111 
: 00110001000000000010 
: 00000001000000001111 
: 00000000000000000010 
: 00000101010000001111 
: 00001110000100000010 
: 00001000000000001111 
: 00000000000000000010 
: 00010010001000001111 
: 00000000000000000010 
: 00001000000000001111 
: 00000000000000000010 
: 00000000010000001111 
: 00000000000000000010 
: 00010111000000001111 


00000000000000000011 
00001000000000000011 
00000100000000000011 
00000010000000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00000110001000000011 
00000001010000000011 
00000101000000000011 
00100101000000000011 
00000000000000000011 
00000001000000000011 
00000000010000000011 
00000000000000000011 
00000100000000000011 
00001001000000000011 
00000000000000000011 
; 00000100000000000011 
: 00000001000000000011 
; 00001001000000000011 
: 00000100000000000011 
: 00000000010000000011 
: 00010000010000000011 
: 00000000010000000011 
: 00100000010000000011 
: 00000000000000000011 
: 00111111110000000011 
: 00000001000000000011 
: 00101000000000000011 
: 00000011000000000011 
: 00000001000000000011 
: 00000110000000000011 
; 00010000000000000011 
: 00000000000000000011 
: 00000000001000000011 
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00000000000000000001 
00000000000000000100 
00000001000000000001 
00000000000000000100 
00000000000000000001 
00000010000000000100 
00000000000000000001 
00000100000000000100 
00001001000000000001 
00000001010000000100 
00011111011000000001 
00100001000000000100 
00000001001000000001 
00000001010000000100 
00000001000000000001 
00001000000000000100 
00000001000000000001 
00000000000000000100 
00001101000000000001 
00000000000000000100 
00000001010000000001 
00000001000000000100 
00000000000000000001 
00000001000000000100 
00001001010000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00001011001000000100 
00000000000000000001 
00000101000000000100 
00010011001000000001 
00011111011000000100 
00010111000000000001 
00000001011000000100 
00000000000000000001 
00000001000000000100 
00000010000000000001 
00000000000000000100 
00000000011000000001 
00100011000000000100 
00100101010000000001 
00000001000000000100 
00000101000000000001 
00000001000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000000001000000100 
00000011000000000001 
00000001000000000100 
00000100000000000001 
00000011010000000100 
00000011000000000001 
00000000000000000100 
00000000000000000001 
00010001010100000100 
00000000000000000001 
00000000000000000100 
00000010000000000001 
00100000011000000100 
00101000000000000001 
00000001001000000100 
00000101000000000001 
00000000000000000100 
00001000000000000001 
00000110000000000100 
00000101000000000001 
00000001010000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000010000000000001 


: 00000000000000000010 
I 000000000000000011H 
! 00000000000000000010 
; 00000010000000001111 
: 00000000000000000010 
; 00000000001000001111 
: 00000000000000000010 
: 00000011000000001111 
: 00000000001000000010 
: 0000000nil00000mi 
: 00010111001000000010 
: 00000011000000001111 
: 00000000000000000010 
: 00000111010000001111 
: 00000111000000000010 
: 00000011010000001111 
: 00000001000000000010 
: 00000000000000001111 
: 00000000000000000010 
: 00000111000000001111 
: 00000000001000000010 
: 00000001001000001111 
: 00000000000000000010 
: 00010010010100001111 
: 00001000000000000010 
: 00000001000000001111 
: 00000001000000000010 
: 00000000000000001111 
: 00000111000000000010 
: 00101001010000001111 
: 00000010000000000010 
: 00000001000000001111 
: 00000101000000000010 
: 00001001000000001111 
: 00011000000000000010 
: 00010111010000001111 
: 00000001010000000010 
: 00000011000000001111 
: 00000101000000000010 
: 00000010000000001111 
: 00000000000000000010 
: 00000000100000001111 
: 00100001000000000010 
: 00001000000000001111 
: 00000011000000000010 
: 00001100001000001111 
: 00000000000000000010 
: 00000101000000001111 
: 00000000000000000010 
: 00000100000000001111 
: 00000001000000000010 
: 00000001000000001111 
: 00000101000000000010 
: 00000111000000001111 
: 00000000000100000010 
: 00000101001000001111 
: 00000000000000000010 
: 00000000000000001111 
: 00000100001000000010 
: 00010111011000001111 
: 00000000000000000010 
: 00000001011000001111 
: 00000000000000000010 
: 00000010011000001111 
: 00000000000000000010 
: 00000100001000001111 
: 00000000000000000010 
: 00000000110000001111 
: 00000100000000000010 
: 00000010000000001111 
: 00000000000000000010 
: 00001000000000001111 
: 00000000000000000010 
: 00000110000000001111 
: 00000001000000000010 
: 00000000000000001111 
: 00000000000000000010 


: 00000000000000000011 
: 00101000000000000011 
: 00000000000000000011 
: 000000000000000000H 
: 00000101000000000011 
: 00000000000100000011 
: 000000100000000000ii 
: 00100000000000000011 
: 00000001000000000011 
: 00000101000000000011 
: 00000000000000000011 
: 00000100001000000011 
: 000000000000000000H 
: 00000000000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00001010000000000011 
: 00010101000000000011 
: 00000000000000000011 
: 00001011000000000011 
: 00000001100000000011 
: 00000000000000000011 
: 00000101010100000011 
: 00000000000000000011 
: 00000100000000000011 
: 00000111000000000011 
: 00000011000000000011 
: 00000001000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00010000000000000011 
: 00000000001000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000010000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000000000000011 
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00000000000000000100 : 
00001101000000000001 : 
00000000000000000100 : 
00001001000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00000000001000000100 : 
00011001011000000001 : 
00000010010000000100 : 
00000000001000000001 : 
00000001001000000100 : 
00000000000000000001 : 
00000010000000000100 : 
00000000000000000001 : 
00000011000000000100 : 
00000100000000000001 : 
00100101010000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00010010010000000001 : 
00000000001000000100 : 
00000000000000000001 : 
00000010000000000100 : 
00000000010000000001 : 
00000000010100000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00000010000000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000000000000000001 ; 
00000000010000000100 : 
00000000000000000001 : 
00000001000000000100 : 
00101101011000000001 : 
00010001011000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000000010000000001 : 
00000010000000000100 : 
00000001011000000001 : 
00000001001000000100 : 
00000000000000000001 : 
00011011000000000100 : 
00000000010000000001 : 
00000000001000000100 : 
00000111000000000001 : 
00000001000000000100 : 
00000000000000000001 : 
00000010000000000100 : 
00000000010000000001 : 
00000011000000000100 : 
00100000000000000001 : 
00001000000000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00000010001000000100 : 
00000000010000000001 : 
00000001001000000100 : 
00000000000000000001 : 
00000101000000000100 : 
00000001000000000001 : 
00010100000000000100 : 
00000000000000000001 : 
00000100000000000100 : 
00001101000000000001 : 
00000101000100000100 : 
00000001000000000001 : 
00000000000000000100 : 
00000001000000000001 : 
00000011000000000100 : 


00001000000000001111 
00000000000000000010 
00000000000000001111 
00000000000000000010 
00000000000000001111 
00000000010000000010 
00001001000000001111 
00100001000000000010 
00000101000000001111 
00000000010000000010 
00000000101000001111 
00010001000000000010 
00000000001000001111 
00010110000000000010 
00000000010000001111 
00011000000000000010 
00000100000000001111 
00000100000000000010 
00000000000000001111 
00000000000000000010 
00000001011000001111 
00001100000000000010 
00010011000100001111 
00000000000000000010 
00000000000000001111 
00001000001000000010 
00000000000100001111 
00000000000000000010 
00000000010000001111 
00000001000000000010 
00001110001010001111 
00000000000100000010 
00000001001000001111 
00000000000000000010 
00000000010000001111 
00000000000000000010 
00000000000000001111 
00110110010000000010 
00000111011000001111 
00000011110000000010 
00001001000000001111 
00000000000000000010 
00001001000000001111 
00000001000000000010 
00011000010000001111 
00011001000100000010 
00010011000000001111 
00000000000000000010 
00000000001100001111 
00001000000000000010 
00000010000000001111 
00000000000000000010 
00000000000000001111 
00000001000000000010 
00001111001000001111 
00000000000000000010 
00001000000000001111 
00000000000000000010 
00000100010000001111 
00010000000000000010 
00000000001000001111 
00000000001000000010 
00000000001000001111 
00000000000000000010 
00000011000000001111 
00001001000000000010 
00011001000000001111 
00000101010100000010 
00000001000000001111 
00000001000000000010 
00000101010000001111 
00000000000000000010 
00010111000000001111 
00000100010000000010 
00000000000000001111 


: 00010100000000000011 
: 00000100000000000011 
: 00000000010000000011 
: 00000011000000000011 
: 00000000001000000011 
: 00000000001000000011 
: 00000011000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000011000000011 
: 00001010000000000011 
: 00000000000000000011 
; 00000000010000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000011000000000011 
: 00000000000000000011 
: 00010100010000000011 
: 00000000000000000011 
: 00000000001100000011 
: 00000111010000000011 
: 00010101000100000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00010001000000000011 
: 00100101000000000011 
: 00000000000000000011 
: 00000001000000000011 
: 00000000010000000011 
: 00000000000000000011 
: 00000001000000000011 
: 00000000000000000011 
: 00000100000000000011 
: 00000101000000000011 
: 00000010000000000011 
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00001001000000000001 
00010011000000000100 
00000010000000000001 
00000000010000000100 
00001000001000000001 
00000000001000000100 
00000000010000000001 
00000000010000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000001010000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000000001000000001 
00000000000000000100 
00011001000100000001 
00011011000000000100 
00000000000000000001 
00000000000000000100 
00011101000000000001 
00000001000000000100 
00000101001000000001 
00010011000000000100 
00000001000000000001 
00000101000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000011000000000100 
00000010000000000001 
00000011111000000100 
00000001000000000001 
00000000000000000100 
00000011010000000001 
00000000010000000100 
00000000000000000001 
00000000000000000100 
00000011000000000001 
00000000000000000100 
00000101000000000001 
00000000000000000100 
00000010000000000001 
00000001010000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000000001000000100 
00000001001000000001 
00000001000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000001000000000100 
00000100010000000001 
00000000010000000100 
00010000000000000001 
00011101000000000100 
00011111011000000001 
00000001000000000100 
00010000000000000001 
00001000000000000100 
00000000001000000001 
00100010000000000100 
00011101000000000001 
00000011010000000100 
00000000001000000001 
00000000000000000100 
00000000000000000001 
00000010000000000100 
00000000010000000001 
00001101000000000100 
00010000000000000001 


00000001000000000010 
00100111000000001111 
00011111000000000010 
00000111010000001111 
00010000000000000010 
00010000000000001111 
00000000001000000010 
00000001000000001111 
00000000000000000010 
00000000000000001111 
00001000000000000010 
00000000000000001111 
00000000000000000010 
00000000000000001111 
00000010000000000010 
00000011001000001111 
00000000010000000010 
00000000000000001111 
00010001000100000010 
00000001000100001111 
00010011000000000010 
00000000000000001111 
00000111000000000010 
00010011000000001111 
00000001000000000010 
00000001000000001111 
00000100000000000010 
00000000011000001111 
00000000000000000010 
00000001000000001111 
00001000000000000010 
00000000000000001111 
00000001011000000010 
00010111011000001111 
00000001000000000010 
00000010000000001111 
00000000010000000010 
00000001010000001111 
00000000000000000010 
00000001000000001111 
00000000100000000010 
00000110000000001111 
00000111000000000010 
00000001000000001111 
00000000000000000010 
00110111000000001111 
00000010000000000010 
00000000000000001111 
00000000010000000010 
00000101000000001111 
00000010000000000010 
00000000010000001111 
00000010000000000010 
00000000000000001111 
00000001000000000010 
00000000010000001111 
00000001000000000010 
00000100000000001111 
00000000000000000010 
00000101000000001111 
00011111000000000010 
00001001010000001111 
00010111000100000010 
00000111000000001111 
00000001000000000010 
00000000000000001111 
00101110010000000010 
00010110010000001111 
00000001010000000010 
00111011000000001111 
00000000000000000010 
00000100010000001111 
00000000000000000010 
00000000000000001111 
00010101001000000010 
00000101011000001111 
00000000000000000010 


00100011001000000011 
00000000000000000011 
00000000001000000011 
00011010000000000011 
00001000000000000011 
00000000000000000011 
00000000000000000011 
00000000010000000011 
00000000000000000011 
00010111000000000011 
00000001000000000011 
00000101001000000011 
00000000000000000011 
00000001010000000011 
00000000000000000011 
00000001000000000011 
00000011100000000011 
00000000010000000011 
00000001000000000011 
00000000000000000011 
00000001000000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00001010010000000011 
00000000000000000011 
00000000000000000011 
00000011000000000011 
00000000000000000011 
00000010000000000011 
00001100000000000011 
00100000000000000011 
00001011011000000011 
00100010011000000011 
00000101011000000011 
00000010000000000011 
00000000001000000011 
00011100000000000011 
00000000000000000011 
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00000001000000000100 : 
00000000000000000001 : 
00100000000000000100 : 
00000001010000000001 : 
00000000000000000100 : 
00000100000000000001 : 
00000100000000000100 : 
00000010000000000001 : 
00000000000000000100 : 
00000010000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00000011000000000100 : 
00000000000000000001 : 
00000010000000000100 : 
00100000000000000001 : 
00000010000000000100 : 
00000000011000000001 : 
00000100010000000100 : 
00000000000000000001 : 
00010000010000000100 : 
00000011000000000001 : 
00000011010000000100 : 
00001001011000000001 : 
00000000010000000100 : 
00000001000000000001 : 
00010101000000000100 : 
00000101000000000001 : 
00000000000000000100 : 
00000111011000000001 : 
00000001001000000100 : 
00000011000000000001 : 
00000010000000000100 : 
00000101001000000001 : 
00000001000000000100 : 
00000000000000000001 : 
00000110000000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00000011010000000100 : 
00000010000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00000000001010000100 : 
00100000000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00010011011000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00100000000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00000000010000000100 : 
00000001000000000001 : 
00000001000000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000010000000000001 
00000001000000000100 
00000111000000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000011010000000001 
00000101000000000100 
00000000000000000001 
00000001000000000100 
00000000010000000001 
00000000000000000100 
00000000000000000001 
00001000000000000100 
00000000000000000001 
00010000000000000100 


00000001000000001111 
00000101000000000010 : 
00000011010000001111 
00000001000000000010 : 
00000000000000001111 
00001001000000000010 : 
00000000000000001111 
00000000001000000010 : 
00000001000000001111 
00000001000000000010 : 
00000101000000001111 
00000100000000000010 : 
00000011010000001111 
00000000000000000010 : 
00000100000000001111 
00000001010000000010 : 
00001001011000001111 
00101101011000000010 : 
00010011011000001111 
00000001000000000010 
00000111001000001111 
00000000100000000010 
00111111111000001111 
00000001000000000010 
00000111000000001111 
00000000000000000010 
00000111000100001111 
00000010000000000010 
00000001000000001111 
00010001000000000010 
00010001010000001111 
00001101000000000010 
00001000000000001111 
00000011011000000010 
00000000000000001111 
00000001010100000010 
00000001100000001111 
00000010000000000010 
00001000000000001111 
00000011000000000010 
00000011000000001111 
00000100010000000010 
00000010000000001111 
00000000000100000010 
00000001001000001111 
00000111000000000010 
00000001000000001111 
00000000010000000010 
00000011001000001111 
00000000000000000010 
00000011000000001111 
00000010000000000010 
00000001000000001111 
00000000010000000010 
00001001011000001111 
00001101000000000010 
00000111000000001111 
00000000000000000010 
00010001000000001111 
00110011000000000010 
00000011000000001111 
00000011000000000010 
00010111000000001111 
00001010000000000010 
00011000011000001111 
00000000000000000010 
: 00000011000000001111 
: 00000000000000000010 
: 00000000000000001111 
: 00000000000000000010 
: 00100111010000001111 
: 00000000000000000010 
: 00000101000000001111 
: 00000000001000000010 
: 00000000000000001111 


00000001000000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00000000000100000011 
00001010000000000011 
00000000000000000011 
00110110000000000011 
00010000000000000011 
00000011000000000011 
: 00010010000000000011 
: 00000000001000000011 
: 00100011000000000011 
: 00000001000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000001000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00001000000000000011 
: 00000001011000000011 
: 00010000000000000011 
: 00000100001000000011 
: 00000010000000000011 
: 00010011000000000011 
: 00000000000000000011 
: 00000001000000000011 
: 00000000000000000011 
: 00000001000000000011 
: 00000100000000000011 
: 00000000000000000011 
: 00000010000000000011 
: 00000000000000000011 
: 00000000001000000011 
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00000000000000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00001000010000000001 
00000000000000000100 
00000001000000000001 
00000000000000000100 
00000000000000000001 
00000000010000000100 
00000001000000000001 
00000010000000000100 
00111100110000000001 
00010110000000000100 
00000000000000000001 
00000000000000000100 
00000001011000000001 
00000000001000000100 
00001010010000000001 
00000001000000000100 
00010010010000000001 
00010001010000000100 
00000000000000000001 
00000000000000000100 
00000110000000000001 
00000010000000000100 
00000000000000000001 
00000100000000000100 
00000010001000000001 
0000001 1 000000000100 
00000000001000000001 
00000001011000000100 
00000000000000000001 
00000000000000000100 
00000000010000000001 
00010000000000000100 
00000111010000000001 
00000001010000000100 
00000001001000000001 
00000000000000000100 
00000000000000000001 
00000000011000000100 
00000000000000000001 
00000000001000000100 
00000001000000000001 
00000000000000000100 
00000000001000000001 
00000101000000000100 
00000000000000000001 
00000000000000000100 
00000001000000000001 
00000100010000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000011011000000001 
00000110010000000100 
00010011000100000001 
00000000000000000100 
00000000000100000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000010000000000001 
00101000000000000100 
00001000000000000001 
00000000000000000100 
00110111010000000001 
00000000000000000100 
00000001000000000001 
00000111010000000100 
00000000000000000001 
00000011000000000100 
00000000001000000001 


00000000000000000010 
00000000000000001111 
00000000000000000010 
00000000010000001111 
00000000000000000010 
00000000000000001111 
00000001000000000010 
00000011000000001111 
00000001000000000010 
00000111000000001111 
00000101000000000010 
00001010001000001111 
00000001000000000010 
00100011000000001111 
00001000001000000010 
00000111000000001111 
00000000000000000010 
00000000011000001111 
00000001011000000010 
00111011011000001111 
00000000000000000010 
00000001000000001111 
00000111000000000010 
00000111100000001111 
00000000000000000010 
00000101000000001111 
00000000000000000010 
00000001000000001111 
00000000000000000010 
00000000000000001111 
00000100000000000010 
00000001000000001111 
00000000000000000010 
00000001110000001111 
00000000000000000010 
00000001000000001111 
00000000000000000010 
00000101010000001111 
00000010010000000010 
00011000011000001111 
00000010000000000010 
00000000000000001111 
00000000000000000010 
00000000010000001111 
00000000001000000010 
00000001011000001111 
00000101011000000010 
00000001000000001111 
00001001011000000010 
00000001000000001111 
00000000001000000010 
00000100000000001111 
00000000000000000010 
00000011000000001111 
00000101000000000010 
00000000000000001111 
00000000000000000010 
00000001000000001111 
00000001001000000010 
00010110011000001111 
00000000000000000010 
00000000011000001111 
00000000000000000010 
00101100010000001111 
00000000000000000010 
00000000100000001111 
00000001000000000010 
00000001001000001111 
00000000000000000010 
00001010000000001111 
00100101010000000010 
00001001000000001111 
00000000000000000010 
00000100000000001111 
00000101000000000010 
00000111000000001111 
00000011010000000010 


00000000000000000011 
00000010000000000011 
00000000000000000011 
00000000000000000011 
00000011000000000011 
00000000000000000011 
00000010000000000011 
00000000000100000011 
00000000000000000011 
00000001000000000011 
00110011000000000011 
00000011011000000011 
00000000000000000011 
00000000000000000011 
00000000010000000011 
00000001000000000011 
00000101010000000011 
00000000000000000011 
00000001000000000011 
00000000000000000011 
00000000001000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00000001000000000011 
00000000000000000011 
00000001000000000011 
00000000000000000011 
00000000000000000011 
00000001010000000011 
00000000000000000011 
00001000000000000011 
00000000001000000011 
00110001000000000011 
00000011000000000011 
00000011000000000011 
00000101000000000011 
00000010000000000011 
00000101000000000011 
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00000110000000000100 : 
00000000000000000001 : 
00011111000000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000000010000000001 : 
00001000000000000100 : 
00010010000000000001 : 
00000100000000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000001000000000001 : 
00000111000000000100 : 
00000100000000000001 : 
00000000000000000100 : 
00011000000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00010001000000000100 : 
00000001010000000001 : 
00000000000000000100 ; 
00000001010000000001 : 
00000000010000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000101011000000001 : 
00000100000000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000001011000000001 : 
00000000001000000100 ; 
00001000110000000001 : 
00001001010000000100 : 
00000000010000000001 : 
00000000000000000100 : 
00000000001000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00001101100000000100 : 
00000000000000000001 : 
00000010000000000100 I 
00000000000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000001000000000001 : 
00000101000000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00010001000000000100 : 
00000001010000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00000010000000000100 : 
00000000000000000001 ; 
00000110000000000100 : 
00100000000000000001 : 
00001000000000000100 : 
00000000000000000001 : 
00000000000000000100 I 
00010100000000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00000101000000000100 : 
00001100000000000001 : 
00010000000000000100 : 
00000000001000000001 : 
00010001000000000100 : 
00000000000000000001 : 
00000010000000000100 : 
00000000000000000001 ; 
00000000000000000100 : 


00000100010000001111 
00000000110000000010 
00011111000000001111 
00000000000000000010 
00000000000000001111 
00000110000000000010 
00001111010000001111 
00000000000000000010 
00100000000000001111 
00000000000000000010 
00000000000000001111 
00000000000000000010 
00010001000000001111 
00000011000000000010 
00000000000000001111 
00001101000000000010 
00000101000100001111 
00000000000000000010 
00001111000000001111 
00000000000000000010 
00010010000000001111 
00001111001000000010 
00010001000000001111 
00000000000000000010 
00000000000000001111 
00000000001000000010 
00000000000000001111 
00000010000000000010 
00001000000000001111 
00000000000000000010 
00000000000000001111 
00000001011000000010 
00111011011000001111 
00000001000000000010 
00000001000000001111 
00000000000000000010 
00000001000000001111 
00001101000000000010 
00000100000000001111 
00000000000000000010 
00000000000000001111 
00000000001000000010 
00000100010000001111 
00000000000000000010 
00000000000000001111 
00000000000000000010 
00000000000000001111 
00000000000000000010 
00010111000000001111 
00000001000000000010 
00000001000000001111 
00000000000000000010 
00000100000000001111 
000000000000000000 1 0 
00000000010000001111 
00000000000000000010 
00000011000000001111 
00000001000000000010 
00010001010000001111 
00001000000000000010 
00001000011000001111 
00000000000000000010 
00000000000000001111 
00010000000000000010 
00101001001000001111 
00000100010000000010 
00001001000000001111 
00001001000000000010 
00000000000000001111 
00000000010000000010 
00000011001000001111 
00000000000000000010 
00000000000000001111 
00000000000000000010 
00000001001000001111 


: 00000000000000000011 
: 00001000000000000011 
: 00000011010000000011 
: 00000000010000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000110000000000011 
: 00000100010000000011 
: 00000011010000000011 
; 00000000000000000011 
: 00000000001000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000001000000011 
: 00000001000000000011 
: 00010101000000000011 
: 00000000000000000011 
: 00000001000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000000000000011 
I 00000000000000000011 
: 00000000001000000011 
; 00000001010000000011 
: 00000000000000000011 
I 00000001000000000011 
: 00000000000000000011 
: 00000010010000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000101010000000011 
: 00000100000000000011 
: 00000001000000000011 
: 00000000000000000011 
: 00000000000000000011 
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00000000000000000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000001010000000001 
00000010000000000100 
00000000000100000001 
00000000000000000100 
00000000000000000001 
00000000000000000100 
00000000000000000001 
00000001000000000100 
00000101000000000001 
00000111000000000100 
00010001010000000001 


00000010100000000010 
00000001000000001111 
00000100000000000010 
00000100000000001111 
00000101010000000010 
00000011000000001111 
00001000001000000010 
00000000000000001111 
00000000000000000010 
00000011010000001111 
00001000110000000010 
00000000001000001111 
00000010000000000010 
00000001000000001111 
00000000010000000010 


00000000000000000011 
00001001000000000011 
00000010000000000011 
00000000000000000011 
00000000000000000011 
00000001000100000011 
00000010000000000011 
00000000000000000011 


EURORULES.TXT 





"Predicting International Events," by Philip 
Schrodt, November 1986, page 177. 

A. 
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"Predicting International Events," by Philip 
Schrodt, November 1986, page 177. 

A. 




Programs to accompany article by 
Philip A. Schrodt 
"Predicting International Events" 

BYTE, November, 1986 

Disk contents: 

HCLASS.PAS 

Program source code in Turbo Pascal vers 3.0. 
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HCUASS.COM 

A compiled version of the above. 

MAKERULE.PAS 
MAKERULE.COM 

A utility program which will create a rule set from a data set 

USUKRULES.TXT 

USUK168.TXT 

Sample data set #1 — COPDAB international events data for USA/UK 
USUKRULES contains rules; USUK168 contains 168 events. 

EUR0368.TXT 

EURORULES.TXT 

Sample data set #2 — COPDAB international events data for USA with 
three European states: UK, France, F.R. Germany 

HCLASS.DOC 

Documentation for the programs with sample interpreted output. 


HCLASS.DOC 

"Predicting International Events," by Philip A. 
Schrodt, November 1986, page 177. 


HCLASS PROGRAM DOCUMENTATION 

Philip A. Schrodt 
Department of Political Science 
Northwestern University 
Evanston, IL 60201 
312-491-2642 

(C) 1986, PHILIP A. SCHRODT 
Al I rights reserved 

INTRODUCTION 

HCLASS is a general implementation of a Holland classifier, based 
on the work of John Holland. This discussion assumes that you are 
familiar with Holland classifiers; if not see 

John H. Holland. 1975. Adaptation in Natural and Artificial 
Systems. (Ann Arbor: University of Michigan Press) 

_ .1986. "Escaping Brittleness: The Possibilities 

of General Purpose Algorithms Applied to Para I IeI-Based 

Systems", In R.S. Michelski, J.G. Carbonell and 

T.M. Mitchell (eds.). ^Machine Learning 2__ (Los Altos,CA: 

Morgan Kaufman) chapter 20. 

This program is a generalized version of a program developed for the paper 

Philip A. Schrodt. 1986. "Predicting International Events using a 
Holland Classifier", presented at the International 
Studies Association meetings, Anaheim. 

This paper is available from the author at the address above. A 
condensed version of this paper appears in BYTE in November, 1986 as 

Philip A. Schrodt. 1986. "Predicting International Events" 

The documentation is not going to make a whole heck of a lot of sense 
unless you are acquainted with at least one of those papers. 

This program is my implementation of a Holland classifier scheme. 
Since Holland classifiers are a general type of algorithm, it should NOT 
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be taken as being, in any way, the definitive implementation of a 
classifier. In particular, I was dealina with a somewhat idiosyncratic 
problem (predicting international events) and some of the features which 
I included or left out of the classifier may not make sense in other 
contexts. Also some of the vocabulary I’ve used ('archives’ and ’eons’) 
are mine and not in general use. 

This program was original developed In UCSD Pascal, then translated 
into Turbo Pascal. The program was thoroughly debugged in the original 
version and I think I’ve caught everything on the Turbo version but no 
promises... The original Apple Pascal version is available from the 
author and is functionally identical to the IBM version. 

The program does some basic error checking but it Is 
NOT IDIOT-PROOFED I In particular it assumes that the Input files are in 
the correct format, and it assumes that you have sufficient computer 
experience to know not to enter letters when you are supposed to enter 
number, or to put decimal points in Integers. 

Two sample data and rule sets are included: 

USUKRULES USUK168 

US/United Kingdom COPDAB interactions, 1948-78. 

Data set contains 168 randomly selected archives 

EURORULES EUR0368 

US COPDAB interactions with the United Kingdom, France and 
West Germany. Data set contains 368 randomly selected sets of 
interact Ions. 

The COPDAB data set is the Conflict and Peace Data Bank data set collected 
by Edward Azar of the University of Maryland and made available through 
the Inter-University Consortium for Political and Social Research 
(PO Box 1248, Ann Arbor, MI 48106). Both data sets are those used 
in Schrodt (1986) 


»> RUNNING THE PROGRAM «< 

1. Execute the program HCLASS.COM. 

2. The first prompt is: 

Do you wish to set parameters (Y/N) ? -> 

If you respond Y, the program will display the Parameter menu, 
which allows you to change the values of parameters. 

If you respond N, the default parameter values will be used. 
Parameters can also be changed at any time by Interupting the program 
and using the M(odify option. 

3. The next prompt is 

Do you wish to set a printout label (Y/N) ? -> 

If you respond Y, you can enter a label of up to 10 lines of 
information which will be used as a header for Information 
printed with the P(rint option. The purpose of this is to allow you 
to put identifying information on the output. 

End the label with a blank line — i.e. just type <CR> without 
any characters before it. 

4. The next prompt is 

Enter rule base file name-> 

Enter the name of a text file containing the rules. See the section 
entitled ’RULE FORMAT* for details on the rule base. 

5. The next prompt is 

Enter data base file name-> 
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Enter the name of a text file containing the data base; see the 
section entitled 'DATA FORMAT' for details. 

6. At this point the program will begin running. It may be interupted at 
any point by typing any key. 

INTERUPTING PROGRAM 

Typing any key while the program is running will interupt it and 
give the prompt 

D(isplay, P(rlnt, M(odify, C(ontinue, Q(ult -> 

Type the first letter of the command to execute it. The functions do 
the foI lowing: 

D(isplay — List rules and statistics to the screen 

P(rint — Print rules, parameters and statistics on the 'LST' device, 
which is usually a printer. If your printer is not the 
'LST' device, make the appropriate modifications in the 
program. 

M(odIfy — Modify parameters or edit rules (see MODIFY section below) 

C(ontinue — Continue running program: this ends the interupt menu. 

Q(uit — Quit program. This will generate two additional prompts 

Do you wish to write rules to a file (Y/N/C(anceI) ? -> 

If you respond Y, you will be asked for a file name to write the 
rules to. If you respond C, the Q(uit command will be canceled and 
you will return to the interupt menu. 

Do you really want to quit (Y/N) ? -> 

If you respond Y, the program will terminate; if you respond C, you 
will return to the interupt menu. Note that by Q(uiting, writing the 
rules, and then responding N to the final prompt, you can save 
intermediate copies of the rules. 

In addition, it is possible to Quit out of any Yes/No question, 
or more specifically any query from the function 'Yes’. This is 
primarily useful if one is debugging the guts of the program but I 
left it in there. 


MODIFY 

The M(odify option allows you to change parameters and edit rules 
through mutation and recombination. Mutation and recombination can 
be done manually with a convenient screen editor. The M(odlfy menu 
prompt is: 

L(ist ,R)ecombine, M)utate, Parameters, C)ontinue -> 

These do the following 
L( 1ST 

This lists rules along with their rule number, strength, age and 
number of successful bids. 

M)UTATE 

This is a screen editor for mutating rules. The program first 
prompts with 

Enter rule number -> 

Enter the number of the rule you wish to mutate (rule numbers can be 
found using L(ist ). The rule is then displayed on two lines: the 
first line is the classifier, the second line the message. 


{continued) 
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The mutation point is delineated with | |. This point is moved 
using the left-arrow and right-arrow cursor keys. Entering a T, 
•*» or ’0’ will change the character. When all mutations are 
finished, hit <CR> ["RETURN"]. To cancel the process, hit <E$C>. 

When you have finished the mutation, the program asks 

Enter rule number to be replaced by this rule -> 

This can be any rule, including the one you originally mutated. 
This number is verified with an 

Are you sure (Y/N/Q(uit) -> 

after which the rule is replaced. Q(uit terminates the operation 
without replacing a rule; N allows you the specify another rule. 

Finally, the program asks 

Enter strength of rule-> 

which sets the strength of the new rule. The age and number of 
successful bids for the rule are set to zero. 


R)ECOMBINE 

R(ecombine is a screen editor like M(utate except that it is used to 
create a new rule out of two existing rules. The rules are specified 
In response to the prompts: 

Enter rule number 1 -> 

Enter rule number 2 -> 

Rule 1 is the left part of the new rule; Rule 2 is the right part. 

The two rules are displayed on the screen, with the combined rule 
below them. 

The cross-over point (the point around which recombination occurs 
is shown with a |. This point is moved using the left-arrow and 
right-arrow cursor keys; the display of the resultant rule is changed 
as the cross-over point moves. To fix the cross-over point,hit <CR> 
["RETURN"]. To cancel the process, hit <ESC>. 

The rule to be replaced and the setting of strength are done 
the same way as In M(utate. 


PARAMETERS 

The parameters listed below can be changed. These are displayed on 
the screen; to change type the first one or two letters of the 
parameter (e.g. Bid Adjustment requires typing only *B*; Mutation 
Probability and Match Minimum require 'MU’ and ’MA’ respectively). 
The cursor will go the parameter value, which can then be changed. 


Bid_Adjust = 0.125; 
Reward_Adjust*1.25; 
Newestrength-128; 
Match_Minimum=15; 
Extinct_Prop*0.5; 

Mutation_Prob=0.30; 

Eon_Length=50 ; 

N Eons=10 
T_SampIe=10; 

T_ShuffIe=20; 
Iter_Limit* 5; 
Debug_Leve1*3; 


(* Adjustment proportion for bid *) 

(* Adjustment multiplier for reward *) 

(* Strength of new rules *) 

(* Threshold for acceptable bids *) 

(* Proportion rules extinct at con end *) 

(* Mutation to * probability in new rules *) 

(* Eon length *) 

(* Total number of eons in simulation *) 

(* Sampling time for success record *) 

ShuffIing interval *) 

(* Bidding iteration limit *) 

(* This gives some control over the amount of 
of screen output *) 


C(ONTINUE — Return to the interupt menu. 


PROGRAM CONSTANTS 

The following constants can be changed by recompiling the program; 
changing N_Feature will probably also involve some changes in the input 
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and output formatting. The program is reasonably well documented at 
the procedure I eve I . 


N_Feature-20; 
TwoN_Feature-40; 
N_Rules- 32; 
Board_Size=4; 
SLabeI_$ize»10; 


(* Number of features in message *) 

(* 2*N_Feature *) 

(* # of ruIes *) 

(* # messages board holds *) 

(* Size of array holding run label *) 


Stats_Size»200; (* Size of array saving statistics *) 

N_Stats«3; (* # statistics recorded *) 


Reset Strength-false (* When TRUE, this causes the strength of 

all rules to be reset to New-Strength at 
the end of epch eon *) 


Quiet-false (* Quiets the 'BEL* on alert conditions 

such as 'Do you really want to quit*. 
Bell remains active on more severe 
error conditions such as illegal 
entries *) 

»> PROGRAM INPUT «< 


All input is from ASCII files and for the most part uses the (0,*,1) 
character set. There are two files: one for rules and one for data. 


RULE INPUT FORMAT 


The 32 rules are input in the following order 

<classlfier> * : * <message> <strength> <wins> <age> 

The classifier and message each contain exactly 20 characters. The 
strength, number of wins and age are integers. Only the characters *1*. 
*0* and *** are allowed; other characters will generate an error message 
and then be converted to '*'. Rules are Ieft-justified in the file. 

The following are two sample rules: 

0*0*0*110000000000*0 : *0**0111000*000*1111 128 0 0 

0*0001**00000*000*11 : 0000101*00*00*001111 128 0 0 

When quitting, the program can write rules to a file which can 
subsequently be read back in as a rule set without modification. 

DATA FORMAT 

Data for the classifier consist of four antecedent archives (messages) 
followed by one consequent (target) archive. The target archive MUST 
terminate with a 1111 string; in the system I*ve used the four antecedents 
terminate in 0001, 0010, 0011 and 0100 respectively but this isn't needed. 
All archives contain exactly 20 characters. 

The four messages and targets are entered as two lines with the 
strings separated by * : ’. The following are two examples: 

00000001000000000001 : 00000011011000000010 : 00000011011000000011 
00000110011000000100 : 00100011010000001111 
00000001000000000001 : 00000001011000000010 : 00000011000000000011 
00000000000000000100 : 00000101010000001111 

These things are terribly space consuming and there are two ways around 
this. First, it would be simple to implement a data-compaction scheme 
which replaces runs of 1’s and 0’s with letters, and then unpacks those 
when the data are read. Second, In my own work I reduced data to 
bit-images and stored the 20-bit strings in 2 bytes, then appended the 
serial bits (0001,0010, ..., 1111), which obviously results in a 90% 
compacting of the data. The code for expanding these ( commented out...) 
is included in the listing of the program and (obviously...) involves a 
couple of violations of strongly typed data. 

»> PROGRAM OUTPUT «< 

HCLASS is a modification of a production research program and hence 
it reports a lot of statistics and other Information while it is 
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running. A lot of this will be useless in most applications but I've 
left them in anyway. I will first give a sample of the output, then 
explain It line by line. 

.................. SAMPLE OUTPUT —————— 

Sample 3 Eon 1 Ave. success- 0.67 .vs. 0.69 

_X...XX. [ 0.88] 

Initial Board: 

1 00000011000000000001 0 

2 00000000010000000010 0 

3 00000000000000000011 0 

4 00000011010000000100 0 

T 00000001010000001111 

Rule checking . 


Msg Bid 

Match 

Ru 1 e 

Stren 

Win Age 


1 

14 

38 

1 

139 

1 

3 

2 

14 

38 

18 

128 

0 

3 

3 

16 

38 

5 

151 

2 

3 

4 

12 

40 

20 

128 

0 

3 

Payoff: 

Ru 1 e 

1 : 

20.00 

[ 0.625] 


Payoff: 

Rule 

5 : 

28.00 

[ 0.875] 



Board at iteration 1 
1 00000000000000000110 18 

2 00000111010000001101 20 

T 00000001010000001111 

Rule checking . 

Msg Bid Match Rule Stren Win Age 

1 13 38 25 128 0 3 

2 7 38 4 128 0 3 

Payoff: Rule 25 : 24.00 [ 0.750] 

Board at iteration 2 

1 00000111010000001101 4 

T 00000001010000001111 

Rule checking . 

Msg Bid Match Rule Stren Win Age 

1 7 38 4 121 1 3 

Board at iteration 3 

1 00000111010000001101 4 

T 00000001010000001111 

Rule checking . 

Msg Bid Match Rule Stren Win Age 

1 7 38 4 121 2 3 

Board at Iteration 4 

1 00000111010000001101 4 

T 00000001010000001111 

Rule checking . 

Msg Bid Match Rule Stren Win Age 

1 7 38 4 121 3 3 

Board at Iteration 5 

1 00000111010000001101 4 

T 00000001010000001111 

Rule checking . 

Msg Bid Match Rule Stren Win Age 

1 7 38 4 121 4 3 

===-=- OUTPUT AT END OF EON 


1 

0*0*0*110000000000*0 

*0**0111000*000*1111 

203 

9 

12 

2 

0000*0000*000000*001 

00*00*11*10000*0111* 

200 

11 

12 

3 

*000*00000*0000*0010 

00*00101**00000*1111 

170 

4 

12 

4 

0*0001**00000*000*11 

0000101*00*00*001111 

167 

7 

12 

7 

000*011**00000***0*1 

| 000***0***0000*0*11* 

133 

1 

6 

8 

00000000*000*0*0**10 | 

j 0**0**1*000*000*11** 

130 

2 

12 

16 

00*00*0**11000000*0* 

| 000000**0**00000*1 *1 

98 

15 

12 
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31 *0*0****0**0*0*00*01 | 00**01100*0*00*0**11 
32 **00****00**00000*** j 00*00110*100**001*11 

NuI I 00000001000000001111 

0 0 6 6 8 20 17 28 2 18 


128 0 0 

128 0 0 

7 0 0 0 


0 


0 


Success records by iteration (Holland/statistical/replaces) 
9 0.708 0.688 0.000 

12 0.691 0.716 0.000 


»> EXPLANATION OF OUTPUT «< 


Sample 3 Eon 1 Ave. success* 0.67 .vs. 0.69 

This is the third sample, first eon. The *ave. success* scores give 
the average success score in this eon of the Holland classifier versus the 
modal statistic. 

The success score is 

(# bits correct - # bits incorrect)/(totaI bits) 

The comparison is made against the target string. 

The modal statistic predicts a # 1* if and only if over half of the bits 
encountered thus far in a position are 1*s. This is, under an assortment 
of assumptions, the statistically optimal predictor. The modal statistic 
uses the messages in the rules as well as in the data in deriving these 
predictions (this made sense in my original application to predicting 
international events; it may not make sense in your application...) 

The success statistic for the classifier is reset at the end of each 
eon so that the performance in individual eons can be evaluated. 


_X...XX. [ 0.88] 

This Is the prediction of the modal estimator: predictions which are 
correct are denoted by *.*; incorrect predictions are denoted by 'X*. The 
[ 0.88] Is the success statistic. 


Initial Board: 

1 00000011000000000001 0 

2 00000000010000000010 0 

3 00000000000000000011 0 

4 00000011010000000100 0 

T 00000001010000001111 

This is the initial state of the message board. The board has four 
messages, numbered 1 to 4; the message labeled T is the target. 

The messages are displayed; the *0’s Indicate that the messages were 
posted by the system rather than by other rules. 


Rule checking 


Msg 

Bid 

Match 

Ru 1 e 

St ren 

Win 

Age 

1 

14 

38 

1 

139 

1 

3 

2 

14 

38 

18 

128 

0 

3 

3 

16 

38 

5 

151 

2 

3 

4 

12 

40 

20 

128 

0 

3 


This gives the results of the bidding. The columns are 
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Msg — Message 

Bid — How much was bid for the message 

Match — The ’Match* statistic — 40 is a perfect match; 0 a perfect 
mismatch. 

Rule — Rule which made the bid 

Stren, Win, Age — Strength, # of previous successful bids, and age 
of the rule which made the winning bid. 


Payoff: Rule 1 : 20.00 [ 0.625] 

Payoff: Rule 5 : 28.00 [ 0.875] 

These are the payoffs to the two rules which posted terminal messages. 
The integers (20.00, 28.00) are the amount of the payoff; the numbers in 
brackets are the success statistics. 


Board at iteration 1 
1 00000000000000000110 18 

2 00000111010000001101 20 

T 00000001010000001111 

Rule checking . 

Msg Bid Match Rule Stren Win Age 

1 13 38 25 128 0 3 

2 7 38 4 128 0 3 

Payoff: Rule 25 : 24.00 [ 0.750] 

This is the next iteration, which goes through the same process except 
that now only two messages are on the board, and these have been posted by 
other rules (rule 18 posted message 1, rule 20 posted message 2). This 
Iteration continues until either no messages are left on the board, or else 
the iteration limit (which defaults to 5) is reached. 


. OUTPUT AT END OF EON ««=«« 

At the end of an eon, the rule set is printed along with some statistics. 
The format for printing the rule set is also used in the D(isplay and L(ist 
opt Ions. 


1 

0 * 0 * 0 * 110000000000*0 

* 0 ** 0111000 * 000*1111 

203 

9 

12 

2 

0000 * 0000 * 000000*001 

00 * 00 * 11 * 10000 * 0111 * 

200 

11 

12 

3 

* 000 * 00000 * 0000*0010 

00 * 00101 ** 00000*1111 

170 

4 

12 

4 

0 * 0001 ** 00000 * 000*11 

0000101 * 00 * 00*001111 

167 

7 

12 

7 

000 * 011 ** 00000 *** 0*1 ! 

| 000 *** 0 *** 0000 * 0 * 11 * 

133 

1 

6 

8 

00000000 * 000 * 0 * 0**10 

| 0 ** 0 ** 1 * 000 * 000 * 11 ** 

130 

2 

12 

16 

00 * 00 * 0 ** 11000000 * 0 * 

| 000000 ** 0 ** 00000 * 1*1 

98 

15 

12 

31 

♦ 0 * 0 **** 0 ** 0 * 0 * 00*01 

| 00 ** 01100 * 0 * 00 * 0**11 

128 

0 

0 

32 

** 00 **** 00 ** 00000 *** 

j 00 * 00110 * 100 ** 001*11 

128 

0 

0 


The rules are printed in the following order 

<rule #> <classifier> | <message> <strength> <# successful bids> <age> 


Nu I I 00000001000000001111 

00668 20 17 28 2 18 70000 
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This gives the current modal predictor string, and the numbers below 
It give the total occurences of 'Vs in each of the positions of the string. 


Success records by iteration (Holland/statistical/replaces) 

9 0.708 0.688 0.000 

12 0.691 0.716 0.000 

This gives a record of the success statistics as a function of the number 

of samples. The format is 

<sample #> <ave Holland success> (ave modal success> <# replaces> 

The number of replaces is the number of times a rule was replaced because 
no rule was able to make an acceptable bid. 

The key here is to set the sampling interval considerably shorter 
than the Eon-Length — for example during my experiments I usually had 
an Eon Length of 100 and a sampling interval of 10. The current program 
has space for 200 samples. This way one can watch the system learn over 
the course of experiments. 

The average Holland statistics are reset at the beginning of each 

eon. 


»> MAKERULE PROGRAM «< 

A program named MAKERULE is included with the system which creates 
a set of rules out of a data set. The data set follows the same format 
as above. MAKERULE prompts for the names of the input and output 
files and otherwise is self-explanatory. Mutation_Prob is set as a 
constant in the program (currently set at 30 (l.e. 0.3)); obviously 
this could be changed to a prompted value without difficulty. 


USUKRULE.TXT 

"Predicting International Events," by Philip A. 
Schrodt, November 1986, page 177. 


0*0*0*110000000000*0 

*0**0111000*000*1111 

128 

0 

0 


0*0001**00000*000*11 

0000101*00*00*001111 

128 

0 

0 


0000*111000*00*0*0*1 

**01**0**10*00*01111 

128 

0 

0 


**00**110**0*0**0**1 

*0**011*010000*01**1 

128 

0 

0 


0000*0000*000000*001 

00*00*11*10000*0111* 

128 

0 

0 


00*0**00*00000000011 

*0**11110000*00*1*1* 

128 

0 

0 


0001*001******000*00 

00010**0*000**0*11*1 

128 

0 

0 


00000111011****0000* 

00*0*0010*1*00*0*111 

128 

0 

0 


0*0**0*1000*0*0***1 * 

001*10*1011*0*0*111* 

128 

0 

0 


00*0***100*0*00000** 

000001100100**0*1111 

128 

0 

0 


*0000**1*0*****0*01 * 

0**000*1*00000*0*111 

128 

0 

0 


*00**0*00*0**0000011 

0011011101*00000*1*1 

128 

0 

0 


0*0**0*0010*0***0001 

0**00111*000*000*111 

128 

0 

0 


00000000*000*0*0**10 

0**0**1*000*000*11** 

128 

0 

0 


**000101*11**0000100 

*00001**001000*01111 

128 

0 

0 


0000101*00000*00*10* 

0011001100*0*0**1111 

128 

0 

0 


000000*10*00*00**011 

0001010**0000000*111 

128 

0 

0 


**0000000100000*0011 

*0000000*000*000*11* 

128 

0 

0 


000**0*0*****00001** 

****11010110*00**111 

128 

0 

0 


000000**0*00*00*0100 

000*01*10100*00*11*1 

128 

0 

0 


00000**1000*00***100 

000*0*010110000011*1 

128 

0 

0 


001*0011000**0**00*1 

0*0001***1*0**0**1** 

128 

0 

0 


*00*0100*000*0*00*10 

0001*00100*0*000*11* 

128 

0 

0 


*0001*0*1***00000*1* 

0**0**1111*0*000**1* 

128 

0 

0 


*000*00000*0000*0010 

00*00101**00000*1111 

128 

0 

0 


*000***10000*0000*11 

0***010110*****01111 

128 

0 

0 


00000*010*00000000** 

0000**0*01**0*0*11** 

128 

0 

0 


00*00*0**11000000*0* 

000000**0**00000*1 * 1 

128 

0 

0 

(continued) 
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0000000000 * 00 * 00 * 0*1 : 
00 * 00 * 1000 * 000 * 0*011 : 
00 ** 00 * 0 * 00000 * 0 * 0*1 : 
* 01110 * 10000 *** 0**00 : 


0000**010****00***1 * 128 

0***1*01*00*0000*1*1 128 

0000010*0*0000*0111* 128 

00**000*001*00001111 128 


0 

0 

0 

0 


0 

0 

0 

0 


USUK168.TXT 

"Predicting International Events," by Philip A. 
Schrodt, November 1986, page 177. 


00000001000000000001 
00000110011000000100 
00000001000000000001 
00000000000000000100 
00000011000000000001 
00000011010000000100 
00001010000000000001 
00001001010000000100 
00000000000000000001 
00000001010000000100 
00000011010000000001 
00000000000000000100 
00000011101100000001 
00000011001000000100 
00000001000000000001 
00000011000000000100 
00000000010000000001 
00000111001000000100 
00000001010000000001 
00000010000000000100 
00000111000000000001 
00010101010000000100 
00000110000000000001 
00001000000000000100 
00000100000000000001 
00000001000000000100 
00000000001000000001 
00000001000000000100 
00000000000000000001 
00000000000000000100 
00000001000000000001 
00000001000000000100 
00110000000100000001 
00000000000000000100 
00000110000000000001 
00001110000000000100 
00000000001000000001 
00001011000000000100 
00000001010000000001 
00000000010000000100 
00000100000000000001 
00010000010000000100 
00000111010000000001 
00000111010000000100 
00100001000000000001 
00000000000000000100 
00000111000000000001 
00000111000000000100 
00001000011000000001 
00000000000000000100 
00000111010000000001 
00000101001000000100 
00010111011000000001 
00000010000000000100 
00100001000000000001 
00000011000000000100 
00000100000000000001 
00000000000000000100 
00110010001000000001 
00000001000000000100 
00110000000000000001 
00000000010000000100 
00000000010000000001 


00000011011000000010 
00100011010000001111 
00000001011000000010 
00000101010000001111 
00000000010000000010 
00000001010000001111 
00010111000000000010 
00101111010000001111 
00010001000000000010 
00001101000000001111 
00000000000000000010 
00000000000000001111 
00100111011000000010 
00101011010000001111 
00000001011000000010 
00000101010000001111 
00000100000000000010 
00000011000000001111 
00000101001000000010 
00000001001000001111 
00000111000000000010 
00000110000000001111 
00000000000000000010 
00000111000000001111 
00000010000000000010 
00000110000000001111 
00000001010000000010 
00001101010000001111 
00110000000000000010 
00000000001000001111 
00010101010000000010 
00000111010100001111 
00000000010000000010 
00010011000000001111 
00000000000000000010 
00000111000000001111 
00000000000000000010 
00111101001000001111 
00000111000000000010 
00001111010000001111 
00000001000000000010 
00000111000000001111 
00100011011000000010 
00011111000000001111 
00000001000000000010 
00001100001000001111 
00000011000000000010 
00000111000000001111 
00000001010000000010 
00000101000000001111 
00000101011000000010 
00010111000100001111 
00011000000000000010 
00000110000000001111 
00001000000000000010 
00101111010000001111 
00000100000000000010 
00000001011000001111 
00000001000000000010 
00110101011000001111 
00000011000000000010 
00000100000000001111 
00001001011000000010 


00000011011000000011 
00000011000000000011 
00000000000000000011 
00000110010000000011 
00000011000000000011 
00000100000000000011 
00000000000000000011 
00000000000000000011 
00000000000000000011 
00110110000000000011 
00000001000000000011 
00000011000000000011 
00000100000000000011 
00000000000000000011 
00000000010100000011 
00010010010000000011 
00000000001000000011 
00000011000000000011 
00000001001000000011 
00011111000000000011 
00000001010000000011 
00000010000000000011 
00000000001000000011 
00000011000000000011 
00000000010000000011 
00000001000000000011 
00010000001000000011 
00000011000000000011 
00000000000000000011 
00111010000000000011 
00000000010000000011 
00010011010000000011 
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00000111000000000100 : 
00110001000100000001 : 
00000111001000000100 : 
00000001000000000001 : 
00000000000000000100 : 
00000011000000000001 : 
00000111000000000100 : 
00000101000000000001 : 
00000000000000000100 ; 
00001000000000000001 : 
00000000000000000100 : 
00000111011000000001 : 
00000111000000000100 : 
00100100000000000001 : 
00000101000000000100 : 
00000000000000000001 : 
00000000100000000100 : 
00010000010000000001 : 
00000101100000000100 : 
00000001001000000001 : 
00000000000000000100 : 
00000000000000000001 : 
00010001000000000100 : 
00001001000000000001 : 
00000100000000000100 : 
00000110100000000001 : 
00000000000000000100 : 
00000011010000000001 : 
00000011000000000100 : 
00000111000000000001 : 
00000111000000000100 : 
00011111000000000001 : 
00000111100000000100 : 
00001101001000000001 : 
00000101000000000100 : 
00000001000000000001 : 
00001010001000000100 : 
00000000000000000001 : 
00000101000000000100 : 
00000101110000000001 : 
00000010000100000100 : 
00001001000000000001 : 
00000010000000000100 : 
00011101010000000001 : 
00000100000000000100 : 
00000000000000000001 : 
00000001010000000100 : 
00000011010000000001 : 
00000000110000000100 : 
00000000010000000001 : 
00000101000000000100 : 
00000000001000000001 : 
00000111010000000100 : 
00000000010000000001 : 
00000000010000000100 : 
00000001011100000001 : 
00011001001000000100 : 
00000000000000000001 : 
00000000000000000100 : 
00001000001000000001 : 
00011101001000000100 : 
00010001000000000001 : 
00001101000000000100 : 
00000100100000000001 : 
00000011010000000100 : 
00000000000000000001 : 
00100001000100000100 : 
00000000000000000001 : 
00000001010000000100 : 
00001101000000000001 : 
00000000000000000100 : 
00001111000000000001 : 
00011011011000000100 : 
00000110000000000001 : 
00000001000000000100 : 


00000111000000001111 
00000001000000000010 
00001011110000001111 
00100101000000000010 
00100001000000001111 
00001000000000000010 
00000011011000001111 
00000110000000000010 
00000011010000001111 
00000000011000000010 
00000101000000001111 
00100010010000000010 
00011111010000001111 
00010101000000000010 
00000001000000001111 
00000110000000000010 
00110010110000001111 
00011111000000000010 
00000111000000001111 
00110110000000000010 
00000111000000001111 
00000000000000000010 
00000100000000001111 
00000100000000000010 
00000111000000001111 
00000011100000000010 
00001011001000001111 
00000011011000000010 
00010111000000001111 
00000101000000000010 
00000111010000001111 
00001111000000000010 
00000111000000001111 
00000001000000000010 
00000011000000001111 
00001001001100000010 
00010011000100001111 
00000000000000000010 
00000111010000001111 
00000001001000000010 
00000100000000001111 
00001001000000000010 
00000101000000001111 
00000101100000000010 
00011001011100001111 
0000000 1 00 1 0000000 1 0 
00000000000000001111 
00000001010000000010 
00100001000000001111 
00000 1 0 1 0000000000 1 0 
00000001010000001111 
00000001000000000010 
00100101000000001111 
00100001000000000010 
00011111100000001111 
00000001110100000010 
00000111011000001111 
00001101000000000010 
00000011000000001111 
00000100001000000010 
00011111011000001111 
00000100000000000010 
00000100000000001111 
00000111000000000010 
00000111000000001111 
00001111011000000010 
00001111001000001111 
00010001000000000010 
00001101000000001111 
00000101000000000010 
00000011001000001111 
00010111000000000010 
00010111011000001111 
00000100000000000010 
00000110010000001111 


: 00001110001000000011 
: 00000011010000000011 
: 00000110000000000011 
: 00000100000000000011 
: 00000001010000000011 
: 00000001010000000011 
: 00000100000000000011 
: 00001011000000000011 
: 00011101010000000011 
: 00000010001000000011 
: 00000000000000000011 
: 00000010000000000011 
: 00000000001000000011 
: 00000111000000000011 
: 00000100000000000011 
: 00011101010000000011 
: 00000100000000000011 
: 00011110010000000011 
: 00000001000000000011 
: 00000011010000000011 
: 00000100000000000011 
: 00000111000000000011 
: 00000010000000000011 
: 00000011000000000011 
: 00000101000000000011 
: 00000111000000000011 
: 00000001000000000011 
: 00001111111000000011 
: 00000100000000000011 
: 00010011010100000011 
: 00000000000000000011 
: 00010111000000000011 
: 00011111011000000011 
: 00000011000000000011 
: 00000000000000000011 
: 00001011000000000011 
: 00000000000000000011 


KOHtmufdl 
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00000010010000000001 
00000000000000000100 
00000010010000000001 
00000010000000000100 
00000001010000000001 
00010100000000000100 
00000011010000000001 
00000101010000000100 
00000001001000000001 
00000100001000000100 
00100001000000000001 
00000011000000000100 
00000001010000000001 
00100011000000000100 
00000001000000000001 
00001111001000000100 
00000001010000000001 
00010110011000000100 
00110111010000000001 
00000111010000000100 
00000000000000000001 
00000000010000000100 
00001111000000000001 
00011011011000000100 
00011101000000000001 
00010001000000000100 
00001011001000000001 
00000011010000000100 
00000001001000000001 
00000010000000000100 
00000010000000000001 
00000000000000000100 
00100011011000000001 
00000111000000000100 
00000001011000000001 
00100100000000000100 
00000000011000000001 
00000000001000000100 
00000011000000000001 
00000011000000000100 
00000000000000000001 
00000001000000000100 
00000101000000000001 
00000011000000000100 
00000101000000000001 
00100001000000000100 
00000000001000000001 
00001000000000000100 
00010111000000000001 
00000101000000000100 
00100101000000000001 
00001000011000000100 
00000010011000000001 
00000001000000000100 
00000110010000000001 
00000111010000000100 
00000000000000000001 
00000001000000000100 
00000110100000000001 
00000000000000000100 
00111111011000000001 
00000110000000000100 
00000001010000000001 
00100001000000000100 
00010001010000000001 
00000110000000000100 
00000101011000000001 
00000001010000000100 
00000010010000000001 
00000010000000000100 
00000010000000000001 
00100001000000000100 
00000011000000000001 
00000000000000000100 
00000000000000000001 
00000001000000000100 
00000010000000000001 


00000 1 000000000000 1 0 
00000101000000001111 
00000101000000000010 
00000101010000001111 
000000000000000000 1 0 
00011001100000001111 
000000000 1 00000000 1 0 
00010111010000001111 
00000011010000000010 
00010011011100001111 
0000 1 0000000000000 1 0 
00101111010000001111 
00010101000000000010 
00111111011000001111 
00000101000000000010 
00001000000100001111 
00000111011000000010 
00001111011000001111 
00000111000000000010 
00011111011000001111 
000000000000000000 1 0 
00000000001000001111 
00010111000000000010 
00010111011000001111 
00000101011000000010 
00001011010000001111 
00000101100000000010 
00011111000000001111 
00000011010000000010 
00000011011000001111 
0000000 1 0000000000 1 0 
0000000 1 00000000 1111 
00000010010000000010 
00011111010000001111 
00000001110000000010 
00101101000000001111 
00010001010000000010 
00000000101000001111 
00000011000000000010 
00111011011000001111 
000000000000000000 1 0 
00000110010000001111 
00001101010000000010 
00000101000000001111 
00100011010000000010 
00000001001000001111 
0000000 1 0000000000 1 0 
00111101010000001111 
00000001000100000010 
00010111010000001111 
0000 1 0000000000000 1 0 
00000001010000001111 
00000111010000000010 
00010111001100001111 
00001011010000000010 
00100111011000001111 
00100101000000000010 
00100001000000001111 
00000011100000000010 
00001011001000001111 
00010101011000000010 
00000011000000001111 
00000011100000000010 
00000001010000001111 
00000 1 000000000000 1 0 
00000100000000001111 
00001011010000000010 
00001011011000001111 
000000000000000000 1 0 
00001000000000001111 
00001111011000000010 
00001111001000001111 
00000111000000000010 
00000111011000001111 
00000 1 000000000000 1 0 
00000100000000001111 
000000000000000000 1 0 


00000000000000000011 
00000101010000000011 
00000001010000000011 
00010001000000000011 
00001000001000000011 
00000011000000000011 
00010111000000000011 
00000000001000000011 
00000001011000000011 
00000011011000000011 
00110000000100000011 
00001011000000000011 
00111011000000000011 
00001011010000000011 
00000101010000000011 
00000001000000000011 
00000001010000000011 
00000000000000000011 
00000000010000000011 
00000011010000000011 
00000000000000000011 
00000001010000000011 
00000001010000000011 
00001111001100000011 
00000100100000000011 
00001000000000000011 
00000101011000000011 
00001111010000000011 
00000011010000000011 
00000000001000000011 
00000111011000000011 
00000000010000000011 
00000101000000000011 
00110011000000000011 
00000000000000000011 
00011111011100000011 
00010101010000000011 
00001100000000000011 
00000001000000000011 
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00000001000000000100 : 

00000010011000000001 : 

00000001000000000100 : 

00000101000000000001 : 

00000000000000000100 : 
00000000000000000001 : 
00000011000000000100 : 
00000100000000000001 : 
00000000000000000100 : 
00000111011000000001 : 
00000011010000000100 : 
00000000000000000001 : 
00001101000000000100 : 
00000001000000000001 : 
00000000001000000100 
00011110010000000001 
00000000000000000100 
00000001010000000001 
00011111000000000100 
00000011010000000001 
00000001000000000100 
00000000110000000001 
00000000010000000100 
00000001010000000001 
00010110011000000100 
00000111011000000001 
00110010000000000100 
00000000000000000001 
00000101000000000100 
00010110011000000001 
00010001110000000100 
00000100010000000001 
00000111010000000100 
00000001011000000001 
00000110000000000100 
00100001000000000001 
00000101100000000100 
00000111000000000001 
00000010010000000100 
00000111000000000001 
00001001001100000100 
00010101000000000001 
00000100000000000100 
00000000000000000001 
00000000000000000100 
00010000001000000001 
00000000001000000100 
00000000000000000001 
00001000000000000100 
00000000000000000001 
00000000000000000100 
00001000011000000001 
00000000000000000100 
00000011011000000001 
00001111010000000100 
00011101001000000001 
00111011000000000100 
00100011010000000001 
00000111000000000100 
00000001010000000001 
00001001000000000100 
00101101010000000001 
00000101010000000100 
00000000000000000001 
00000100000000000100 
00010001000000000001 
00000001011000000100 
00000011010000000001 
00000001000000000100 
00000111000000000001 
00000010010000000100 
00000010000000000001 
00000010000000000100 
00000001000000000001 
00010111100000000100 


00000010010000001111 
00000111010000000010 : 
00010111001000001111 
00000101000000000010 : 
00000001010000001111 
00000100000000000010 : 
00001001000000001111 
00000000010000000010 : 
00000001000000001111 
00111011000000000010 : 
00001001011000001111 
00000100000000000010 : 
00000000000000001111 
00001001001000000010 
00100100001000001111 
00001010001000000010 
00000000011000001111 
00000111000000000010 
00001111010000001111 
00000001000000000010 
00000000001000001111 
00100001000000000010 
00011111100000001111 
00000111011000000010 
00001111011000001111 
00000110000000000010 
00110011001000001111 
00000000000000000010 
00000111010000001111 
00001111010000000010 
00000111000000001111 
00000001000000000010 
00000111011000001111 
00010011010000000010 
00000011000000001111 
00000111000000000010 
00001011010000001111 
00000000000000000010 
: 00000001000000001111 
; 00000100000000000010 
; 00011110011000001111 
: 00010010100000000010 
: 00000000001000001111 
: 00001101000000000010 
: 00000011001000001111 
: 00010001010000000010 
: 00000000101000001111 
: 00000010000000000010 
: 00000001010000001111 
: 00000001000000000010 
: 00001101000000001111 
: 00000101000000000010 
: 00011111110000001111 
: 00000111010000000010 
: 00010111111000001111 
: 00011101010000000010 
: 00010011010000001111 
: 00000011011000000010 
: 00010111000000001111 
: 00011000000000000010 
: 00000011010000001111 
: 00001000000000000010 
: 00110011000000001111 
: 00000001010000000010 
: 00000111000000001111 
: 00000011010000000010 
: 00111011011000001111 
: 00000000100000000010 
: 00011001010000001111 
: 00000000000000000010 
: 00000001000000001111 
: 00000101010000000010 
: 00000101010000001111 
: 00000000010000000010 
: 00010100000000001111 


00000101011000000011 
00000101000000000011 
00000000010000000011 
00000000000000000011 
00010001000000000011 
00000101000000000011 
00011011000000000011 
00010011000100000011 
: 00000010000000000011 
: 00100001000000000011 
: 00000001000000000011 
: 00000001011000000011 
: 00000001000000000011 
: 00000001000000000011 
: 00000001011000000011 
: 00110011000000000011 
: 00001011011000000011 
: 00001011001000000011 
: 00000100000000000011 
: 00000001000000000011 
: 00000100000000000011 
: 00000000000000000011 
: 00000000010000000011 
: 00000000000000000011 
: 00000000000000000011 
: 00000101000000000011 
: 00010110011000000011 
: 00000111011000000011 
: 00000011000000000011 
: 00100001000000000011 
: 00010001001000000011 
: 00010000010000000011 
: 00001001000000000011 
: 00100001010000000011 
: 00000100000000000011 
: 00000101010000000011 
: 00011001000000000011 


[continued) 
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00000000000000000001 
00000001010000000100 
00000111000000000001 
00000011000000000100 
00000001000000000001 
00000001000000000100 
00001000000000000001 
00011111011000000100 
00000000000000000001 
00000101000000000100 
00000001000000000001 
00001110000000000100 
00000000000000000001 
00000000000000000100 
00001000001000000001 
00010011000000000100 
00011110001000000001 
00000110000000000100 
00000000000000000001 
00000011100000000100 
00001011011000000001 
00000011000000000100 
00000011000000000001 
00000101010000000100 
00000001000000000001 
00000000000000000100 
00001011001000000001 
00000011000000000100 
00101100010000000001 
00000001000000000100 
00000000001000000001 
00011011000000000100 
00000000000000000001 
00000011010000000100 
00000000000000000001 
00000001001000000100 
00000001011000000001 
00000001010000000100 
00000011011000000001 
00000000000000000100 
00000110000000000001 
00000110000000000100 
00000101010000000001 
00000000000000000100 
00010001010000000001 


00000101000000000010 
00000011011100001111 
00000001000000000010 
00000011010000001111 
00000000000000000010 
00000111000000001111 
00000001000000000010 
00100011000100001111 
00000110000000000010 
00000110000000001111 
00000000000000000010 
00000100000000001111 
00110001000000000010 
00000100010000001111 
00000111010000000010 
00111011010000001111 
00000000001000000010 
00000011000000001111 
00000001010100000010 
00000000001000001111 
00010000010000000010 
00000111000000001111 
00000000000000000010 
00000111011000001111 
00000001011000000010 
00000111010000001111 
00111101010000000010 
00001101001000001111 
00011101010000000010 
00110000000000001111 
00000001000000000010 
00100100001000001111 
00000011001000000010 
00000111011000001111 
00000011010000000010 
00000111010000001111 
00000111011000000010 
00001111000000001111 
00000111000000000010 
00010111010000001111 
00000011000000000010 
00000111001000001111 
00000001000000000010 
00000000010000001111 
00000000000000000010 


00010100111000000011 
00010110000000000011 
00000000000000000011 
00000110011000000011 
00000100000000000011 
00000001000000000011 
00000010010000000011 
00000001000000000011 
00010000000000000011 
00000110100000000011 
00000111000000000011 
00000000000000000011 
00000011000000000011 
00100111010000000011 
00000011011000000011 
00001001001000000011 
00101011010000000011 
00011110000000000011 
00100011010000000011 
00000111000000000011 
00001000000000000011 
00000100000000000011 
00000000001000000011 


README.WAT 

"The Art of Deduction," by J.C. Emond ond A. Poulissen, 
November 1986, page 207. 


The program Watson, described in the article, 

"Elementary, My Dear Watson" in the November 1986 issue of BYTE, 
WATSON.PRO 

You will need a Prolog interpreter to run Watson. 


WT.LOG 

- the 

load file 

KB.MIC 

- the 

knowledge base 

UI.MIC 

- the 

user interface 

JE.MIC 

- the 

justification engine 

CC.MIC 

- the 

consistency checker 

GP.MIC 

- the 

general purpose predicates 
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WATSON.PRO 

"The Art of Deduction," by J.C. Emond and A. Paulissen, 
November 1986, page 207. 


player(P):- member(P, [pi,p2,p3]). 


type(C,suspect)member(C, 
typefC,location)member(C, 
typefC,weapon)member(C, [ 
cardfC):- type(C,suspect). 
card(C)type(C,location). 
card(C)type(C,weapon). 


[si,s2,s3,s4,s5,s6]). 

[11,12,13,14,15,16,17,18,19]). 
wl,w2,w3,w4,w5,w6]). 


may.be.in.the.box(C)cardfC), 

not (owns(pi,C)), 
not fowns(p2,C)), 
not (owns(p3,C)), 
not (( type(C.T), 
type(Cl,T), 
not (C=C1), 
is.i n_the_box(C1))). 


is.in.the.box(C)owns.not(pi,C), 
owns.not(p2,C), 
owns.not(p3,C). 


owns.not(P,C)has.not(P,C). 
owns.not(pi,C)not (has(p1,C)). 
owns.not(P.C)(has.not_both(P,C,Cl); 

has.not_both(P,C1,C) ), 
has(P,C1), 

asserta( has.not(P.C) ). 


owns(P.C):- has(P,C). 

owns(P,C)(has.at.least.one(P,C,C1); 

has.at.least.one(P,C1,C) ), 
has.notfP.C1), 
assertaf has(P.C) ). 


has.at.least.one(P,Cl,C2) 

(has.at.least.one.of.three(P,C,C1,C2); 
has.at.least.one.of.three(P,C1,C,C2); 
has.at.least.one.of.thr ee(P,C1,C2,C)), 
has.not(P,C). 


ask(C):- may.be.i n.the.box(C), !. 

request(Cl,C2,C3)typefCI,suspect), askfCI), 
type(C2,location),ask(C2), 
type(C3.weapon), ask(C3). 


memberfX,[Xl.l). 

member(X,[_|V]):- member(X.Y). 


WT.LOG 

"The Art of Deduction," by J.C. Emond and A. Paulissen, 
November, 1986, page 207. 


?((P "~L") (PP)) 
?((CRWIND "" 8 6 
(PP) 

(P " 

(PP) (PP) 

(P " 



14 66) (CURSOR "" 0 0) 

- WATSON EXPERT SYSTEM -") 

based on the BYTE article ") (PP) (PP) 

Elementary, My Dear Watson ") (PP) 

by ") (PP) 

J-C. EMOND (Belgium) and A. PAULISSEN (Holland)") (PP) 


[continued] 
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(p " 

(p •• 

(pp) (pp) 

(p 

(CRWIND M 
(CURSOR M 
(P " load 
P 
(P 

( p 

(P 


(November 1986)") (PP) (PP) 

For private, non-commercial use only. ") (PP) 


(CUWIND 

(O) 


July 1986, micro-PROLOG version 1.21")) 
loading system components" 006 78)) 
loading system components" 0 0)) 
ing WATSON knowledge base <KB.MIC>") 

loading WATSON user interface <UI.MIC>"‘ 

loading WATSON Justification engine <JE.MIC>“ 
loading WATSON consistency checker <CC.MIC>" 
loading general purpose predicates <GP.MIC>") 

") (CLOSE "loading system components")) 


) ( 

;pp; 


[LOAD “KB .MIC ") 

i) 

) < 

;pp; 


[LOAD "UI.MIC"; 

i) 

) ( 

;pp; 


[LOAD "JE.MIC"; 

i) 

) ( 

[ pp : 


[LOAD "CC.MIC"] 

i) 

(PP) 

(LOAD "GP.MIC"); 



KB.MIC 

"The Art of Deduction," by J.C. Emond and A. Paulissen, 
November 1986, page 207. 


((IS-IN-THE-BOX)) 

((AT-LE AST-ONE- IS-IN-THE-BOX)) 

((HAS-NOT-ALL-THREE)) 

((HAS-NOT-BOTH)) 

((HAS-AT-LEAST-ONE-OF-THREE)) 

((HAS-AT-LEAST-ONE)) 

((THE-BOX-OWNS-AT-LEAST-ONE _c1 _c2) 

(AT-LEAST-ONE-IS-IN-THE-BOX _c1 _c2)) 
((THE-BOX-OWNS-AT-LEAST-ONE _c1 _c2) 

(AT-LEAST-ONE-IS-IN-THE-BOX _c2 _c1)) 
((THE-BOX-OWNS-AT-LEAST-ONE _c1 _c2) 

(AT-LEAST-ONE-IS-IN-THE-BOX _c1 _c2 _c3) 

(PLAYER _p) 

(OWNS _p _c3) 

(CHECK ((AT-LEAST-ONE-IS-IN-THE-BOX _c1 _c2)) ) /) 
((THE-BOX-OWNS-AT-LEAST-ONE _c1 _c2) 

(AT-LEAST-ONE-IS-IN-THE-BOX _c1 _c3 _c2) 

(PLAYER _p) 

(OWNS _p _c3) 

(CHECK ((AT-LEAST-ONE-IS-IN-THE-BOX _c1 _c2)) ) /) 
((THE-BOX-OWNS-AT-LEAST-ONE _c1 _c2) 

(AT-LEAST-ONE-IS-IN-THE-BOX _c3 _c1 _c2) 

(PLAYER _p) 

(OWNS _p _c3) 

(CHECK ((AT-LEAST-ONE-IS-IN-THE-BOX _c1 _c2)) ) /) 
((OWNS-AT-LEAST-ONE _p _c1 _c2) 

(HAS-AT-LEAST-ONE _p _c1 _c2)) 

((OWNS-AT-LEAST-ONE _p _c1 _c2) 

(HAS-AT-LEAST-ONE-OF-THREE _p _c1 _c _c2) 

(HAS-NOT _p _c) 

(CHECK ((HAS-AT-LEAST-ONE _p _c1 _c2)) ) /) 
((OWNS-AT-LEAST-ONE _p _c1 _c2) 

(HAS-AT-LEAST-ONE-OF-THREE _p _c1 _c2 _c) 

(HAS-NOT _p _c) 

(CHECK ((HAS-AT-LEAST-ONE _p _c1 _c2)) ) /) 
((OWNS-AT-LEAST-ONE _p _c1 _c2) 

(HAS-AT-LEAST-ONE-OF-THREE _p _c _c1 _c2) 

(HAS-NOT _p _c) 

(CHECK ((HAS-AT-LEAST-ONE _p _c1 _c2)) ) /) 
((HAS-NOT)) 

((OWNS-NOT-BOTH _p _c1 _c2) 

(HAS-NOT-BOTH _p _c1 _c2)) 

((OWNS-NOT-BOTH _p _c1 _c2) 

(HAS-NOT-ALL-THREE _p _c1 _c _c2) 

(HAS _p _c) 

(CHECK ((HAS-NOT-BOTH _p _c1 _c2)) ) /) 
((OWNS-NOT-BOTH _p _c1 _c2) 

(HAS-NOT-ALL-THREE _p _c1 _c2 _c) 

(HAS _p _c) 

(CHECK ((HAS-NOT-BOTH _p _c1 _c2)) ) /) 
((OWNS-NOT-BOTH _p _c1 _c2) 

(HAS-NOT-ALL-THREE _p _c _c1 _c2) 

(HAS _p _c) 

(CHECK ((HAS-NOT-BOTH _p _c1 _c2)) ) /) 
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((HAS)) 

((OWNS-NOT _p1 _c) 

(IS-PLAYERS-LIST (_p1|_rest)) 

(NOT HAS _p1 _c)) 

((OWNS-NOT _p _c) 

(HAS-NOT _p _c)) 

((OWNS-NOT _p _c) 

(OWNS-NOT-BOTH _p _c1 _c) 

(HAS _p _c1) 

(CHECK ((HAS-NOT _p _c)) ) /) 

((OWNS-NOT _p _c) 

(OWNS-NOT-BOTH _p _c _c1) 

(HAS _p _c1) 

(CHECK ((HAS-NOT _p _c)) ) /) 

((OWNS-NOT _p _c) 

(PLAYER _other-p) 

(NOT EQ _other-p _p) 

(HAS _other-p _c) 

(CHECK ((HAS-NOT _p _c)) ) /) 

((OWNS _p _c) 

(HAS _p _c)) 

((OWNS _p _c) 

(OWNS-AT-LEAST-ONE _p _c1 _c) 

(OWNS-NOT _p _c1 ) 

(CHECK ((HAS _p _c)) ) /) 

((OWNS _p _c) 

(OWNS-AT-LEAST-ONE _p _c _cl) 

(OWNS-NOT _p _c1) 

(CHECK ((HAS _p _c)) ) /) 

((OWNED-BY-THE-BOX _c) 

(IS-IN-THE-BOX _c)) 

((OWNED-BY-THE-BOX _c) 

(TYPE _c .type) 

(FORALL ((TYPE .card .type) (NOT EQ .card _c)) 

((PLAYER _p) (OWNS _p .card))) 

(CHECK ((IS-IN-THE-BOX _c)) ) /) 

((OWNED-BY-THE-BOX _c) 

(FORALL ((PLAYER _p)) ((OWNS-NOT _p _c))) 

(CHECK ((IS-IN-THE-BOX _c)) ) /) 

((OWNED-BY-THE-BOX _c) 

(THE-BOX-OWNS-AT-LEAST-ONE _c .cl) 

(PLAYER _p) 

(OWNS _p _d) 

(CHECK ((IS-IN-THE-BOX _c)) ) /) 

((OWNED-BY-THE-BOX _c) 

(THE-BOX-OWNS-AT-LEAST-ONE .cl _c) 

(PLAYER _p) 

(OWNS _p .cl) 

(CHECK ((IS-IN-THE-BOX _c)) ) /) 

((MAY-BE-IN-THE-BOX _c) 

(IS-IN-THE-BOX _c)) 

((MAY-BE-IN-THE-BOX _c) 

(OWNED-BY-THE-BOX _c)) 

((MAY-BE-IN-THE-80X _c) 

(FORALL ((PLAYER _p)) ((NOT OWNS _p _c))) 

(NOT ? ((TYPE _c .type) (IS-IN-THE-BOX _other-c) (TYPE _other-c .type)))) 

((CARD _c) 

(TYPE _c suspect)) 

((CARD _c) 

(TYPE _c location)) 

((CARD _c) 

(TYPE _c weapon)) 

((TYPE _c suspect) 

(IS-SUSPECTS-LIST _sI 1st) 

(ON _c _sI 1st)) 

((TYPE _c location) 

(IS-LOCATIONS-LIST .lllst) 

(ON _c .lllst)) 

((TYPE _c weapon) 

(IS-WEAPONS-L1ST _wI Is t) 

(ON _c _wl1st)) 

((PLAYER _p) 

(IS-PLAYERS-L1ST _pI 1st) 

(ON _p _pl1st)) 

((IS-WEAPONS-LIST (letter-opener cable phone-cord screwdriver poison-coffee stapler))) 


(confrnuedl 
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((IS-LOCATIONS-LIST (computer-room hall washroom cafeteria 

conference-room closet elevator office library}}} 
((IS-SUSPECTS-LIST ("Miss Doss" "Mrs. Mips " "Mrs. Deadlines" 

"Rev. Reedright" "Dr. Fosfer" "Lt. Bixer"))) 

((IS-PLAYERS-LIST ())) J)) 


UI.MIC 

"The Art of Deduction," by J.C. Emond and A. Paulissen, 
November 1986, page 207. 


(P 

IE 

IE 

(P 

(P 

(P 

(P 

(P 

(P 

if 

(P 

(P 

\l 

SE 


((INTRODUCE) 

(CRWIND introduction 0 0 22 78) 

WATSON is an expert system for use in a card-based") (PP) 

" murder mystery game. WATSON will advise you at every") (PP) 

" stage of the game and In all decisions you have to") (PP) 

" make. If you desire, WATSON will explain and justify the") (PP) 

" advice that it provides.") (PP) 

WATSON also checks the consistency of the information ") (PP) 
it obtains during the game and prints an error message") (PP) 
if consistency is lost due to irrational behaviour or") (PP) 

" cheating.") (PP) 

WATSON is easy to use because it is almost entirely") (PP) 
menu-driven. The system communicates with you by means ") (PP) 
of windows and menus. By using the up and down cursor") (PP) 
arrow keys, you con choose the appropriate option,") (PP) 
which you then confirm by hitting the ccarriage return>") (PP) 

" key.") (PP) ' K ' 

Before starting the game, WATSON needs to know a few ") (PP) 
facts about the players involved, the order they will ") (PP) 
play, and the cords held by the user of WATSON.") (PP) (PP) 

" Hit any key when you are ready to start...") 

(GETB "TRM:" x) 

(CRWIND WATSON 0 0 22 78) 

(CLOSE introduction) 

/) 

((C) 

(INTRODUCE) 

(PLAYER-NAMES-ASKED) 

(ADDCL ((ROUND 0))) 

(ADDCL ((HISTORY 0 (( 

(CARDS-ASKED) 

(BEGUN _p) 

(PLAYED _p) 

(STOP) /) 

((CONTEMPLATED _c .line) 

(CURSOR " just a moment. 

(P " 

(CURSOR " just a moment. 

(P -c» 

((REQUEST _c1 _c2 _c3) 

(CRWIND " just a moment. 

(TYPE _c1 suspect) 

(CONTEMPLATED _c1 2) 

(MAY-BE-IN-THE-BOX _c1) 

(TYPE _c2 location) 

(CONTEMPLATED _c2 3) 

(MAY-BE-IN-THE-BOX _c2) 

(TYPE _c3 weapon) 

(CONTEMPLATED _c3 4) 

(MAY-BE-IN-THE-BOX c3) 

(CUWIND WATSON) 

(CLOSE " Just a moment.. 

((THREE-CARDS-ASKED _s I _w) 

(IS-SUSPECTS-LIST _slist) 

(INMENU _s _slist suspect 0 

(IS-LOCATIONS-LIST _lIist) 

(INMENU _l _llist location 0 
(IS-WEAPONS-LIST _wlist) 

(INMENU _w _wl1st murderweapon 0 10 40) /) 

((EXECUTED _p "asking three cards") 


in round" 0 "the following facts were deduced:")))) 1) 


•) 


_l ine 0) 

_l ine 0) 

5 20 5 20) 


•) /) 

10 40) 
10 40) 
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(CRWIND tab Ie 0 10 22 58) 

(CURSOR table 20 1) 

(P _p "asks ?") 

(THREE-CARDS-ASKED _s _l _w) 

(CHECK ((HAS-NOT-ALL-THREE _p _s _l _w))) 
(CUWIND WATSON) 

(CLOSE table) 

(REQUEST-ANSWERED _p _s _l _w) 

(IS-PLAYERS-LIST _list) 

(SUCCESSOR _p _pnext _list) 


(PLAYED .pnext) /) 

((EXECUTED _p "giving suspicion") 
(INMENU _answer (correct incorrect) 
(EXECUTED _p _answer) /) 

((EXECUTED _p correct) 

(CURSOR WATSON 8 28) 

(P "** Congratulations ") 

(P -P) /) 

((EXECUTED _p incorrect) 

(CRWIND table 0 10 22 58) 

(CURSOR table 20 1) 

(p "What cards has ") 

(P -P) 

(p " mentioned in his/her suspicion 
(THREE-CARDS-ASKED _s _l _w) 

(CHECK ((HAS-NOT _p _s)) ) 

(CHECK ((HAS-NOT _p .1)) ) 

(CHECK ((HAS-NOT _p _w)) ) 

(ADDCL ((DISQUALIFIED _p))) 
(IS-PLAYERS-LIST .list) 

(SUCCESSOR _p _pnext .list) 

(CUWIND WATSON) 

(CLOSE table) 

(PLAYED .pnext) /) 

((EXECUTED nobody _p _s .1 _w) 

(CHECK ((AT-LEAST-ONE-IS-IN-THE 
(IS-PLAYERS-LIST (_p1|_rest)) 
(FORALL ((ON .player .rest) (NOT 
((CHEC 


'suspicion is:" 2 0 30) 


?") 


/) 


(CHECK 

(CHECK 

(CHECK 


((HAS-NOT .player 
((HAS-NOT .player 
((HAS-NOT .player 


BOX _s .1 _w)) ) 
EQ .player _p)) 



((EXECUTED .pi _p _s .1 _w) 

(IS-PLAYERS-LIST (_p1|_rest)) 

(CRWIND table 0 10 22 58) 

(CURSOR table 16 1) 

(ADVISE-TO-SHOW .pi _s _w .1) 

((EXECUTED _p-answered .pi _s .1 _w) 

(IS-PLAYERS-LIST (.pi _p2|_rest)) 

(iNMENU .card (_s .1 _w) "Which card has been shown?" 2 0 30) 
(CHECK ((HAS _p-answered .card)) ) 

(EXECUTED "no answer" _p-answered _p2 _s .1 _w) /) 

((EXECUTED _p1-answered _p _s .1 _w) 

(IS-PLAYERS-LIST (_p1-answered|_rest)) /) 

((EXECUTED _p-answered _p _s .1 _w) 

(CHECK ((HAS-AT-LEAST-ONE _p-answered _s .1 
(IS-PLAYERS-LIST .list) 

(SUCCESSOR _p .pnext .list) 

(EXECUTED "no answer" _p-answered .pnext _s .1 _w) /) 


-w)) ) 


((EXECUTED "no answer 
(EQ _p .p-answered) 
((EXECUTED "no answer 
(CHECK ' 

(CHECK 

(check 


p-answered _p _s .1 _w) 

/) , x 

" p-answered _p _s .1 _w) 

:Tii! 


(HAS-NOT _p 
(HAS-NOT _p _ 

(HAS-NOT _p _w)) 

IS-PLAYERS-LIST .list) 

SUCCESSOR _p .pnext .list) 

(EXECUTED "no answer" .p-onswered .pnext _s _l _w) /) 
((REQUEST-ANSWERED .pi _s .1 _w) 

(IS-PLAYERS-LIST (_p1|_rest)) 

(ASK-WHO .pi .rest _s .1 _w) /) 

((REQUEST-ANSWERED _p _s .1 _w) 


{continued) 
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( IS-PLAYERS-LIST (.pil.rest) 
(SUCCESSOR _p _p1 (_p1|_re$ 
-w)) 


(ON _x (_s _l 
(HAS _p1 _x) 
(CRWIND tab Ie 
(CURSOR table 




58) 


/) 


/) 


0 10 22 
16 1) 

(ADVISE-TO-SHOW _p1 _s _w .1) 

((REQUEST-ANSWERED _p _s _l _w) 

(IS-PLAYERS-L1ST (.pil.rest)) 

(NOT HAS _p1 _8) (NOT HAS _p1 _l) (NOT HAS _p1 _w) 

(APPEND _front (_p|_end) _rest) 

(APPEND _end .front .actual Iist) 

(ASK-WHO _p .actual list _s _l _w) 

((REQUEST-ANSWERED _p _s _l _w) 

(IS-PLAYERS-L1ST _list) 

(APPEND .front (_p|_end) .list) 

(APPEND .end .front .actual Iist) 

(ASK-WHO _p .actual Iist _s .1 _w) 

((ASK-WHO _p .list _s .1 _w) 

(APPEND .list (nobody) .menu Iist) 

(INMENU _p-answered .menulist "Who answers ?" 2 0 30) 

/ 

(EXECUTED _p-onswered _p _s I w) /) 
((REQUEST-PRESENTED (_s .1 _w)) 

(CRWIND table 0 10 22 58) 

(CURSOR table 17 1) 

(p "*** WATSON advises you to ask for: ") 

(CURSOR table 19 5) 

P -s) 

(CURSOR table 20 5) 

(P-0 

(CURSOR table 21 5) 

(P _w) 

(EXPLAIN _s .1 _w) /) 

((SOLUTION-PRESENTED (_s 
(CURSOR WATSON 16 1) 

The solution is 
WATSON 18 5) 


(P "*** 
(CURSOR 
(P -8) 
(CURSOR 

P -I) 

(CURSOR 
(P _w) 
(INMENU 


-I _w)) 
*) 


WATSON 19 5) 
WATSON 20 5) 


.option ( 

(JUSTIFY .option) 

((IS-SOLUTION (_s .1 

(IS-IN-THE-BOX _s) 

(IS-IN-THE-BOX .1) 

(IS-IN-THE-BOX _w) 

(FINAL-CHECK _s .1 

((SUCCESSOR .pi _p2 .list) 

(IS-PLAYERS-LIST (pi _p2|_rest)) 
_P _P1 (_l 


" no" 


-w) 


yes") " justify ? " 17 40 13) 


((SUCCESSOR 


-P)) 


/) 


(IS-PLAYERS-LIST (.pi[.rest)) /) 
((SUCCESSOR _p .pnext (_p .pnextl.rest)) 
((SUCCESSOR _p .pnext (_h|_t)) 

(SUCCESSOR _p .pnext _t) /) 
((DISQUALIFIED)) 

((REMOVED (_p|_rest) _p .rest) /) 
((REMOVED (_h|_rest) _p .resultlist) 
(REMOVED .rest _p .tempiist) 

(APPEND (_h) .tempiist .resultlist) 
((REMOVED (_P) -P 0) /) 

((WEAPONS-ASKED (stop _last-item|()))) 

((WEAPONS-ASKED .menulist) 

(INMENU _s .menulist " murderweapons 
(OR ((EQ _s stop) /) 


/) 


/) 


0 18 30) 


/) 


((IS-PLAYERS-LIST (.pil.rest)) 

(CHECK ((HAS _p1 _s))) 

(REMOVED .menulist _s .newmenuIist) 
(WEAPONS-ASKED .newmenuIist))) 


((LOCATIONS-ASKED (stop .1 ast-ltern|()))) 
((LOCATIONS-ASKED .menulist) 
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(INMENU _s .menuI 1st “ locations " 0 18 30) 


(OR 


/) 


((EQ _s stop) /) 

((IS-PLAYERS-LIST (_p1|_rest)) 

(CHECK ((HAS _p1 _s))) 

(REMOVED .menu I 1st _s .newmenuIist) 
(LOCATIONS-ASKED .newmenuIist))) 


((SUSPECTS-ASKED (stop _last-item|()))) 
((SUSPECTS-ASKED .menulist) 

(INMENU _s .menulist " suspects 

(OR 


0 18 30) 


((EQ _s stop) /) 

((IS-PLAYERS-LIST (_p1|_rest)) 

(CHECK ((HAS .pi _s))) 

(REMOVED .menulist _s .newmenuIist) 

(SUSPECTS-ASKED .newmenuIist))) 

/) % 

((STOP) 

(CURSOR WATSON 21 0) 

(P "Type any key to return to DOS") 

(GETB "TRM:" _x) 

(EXIT 0.)) 

((PLAYED _p) 

(IS-PLAYERS-LIST .1ist) , v 

(FORALL ((ON .ployer .list)) ((DISQUALIFIED .player))) /) 

((PLAYED _p) 

(DISQUALIFIED _p) 

(IS-PLAYERS-LIST .list) 

(SUCCESSOR _p .pnext .list) 

(PLAYED .pnext) /) 

((PLAYED .pi) 

(IS-PLAYERS-LIST (.pi _p2|_rest)) 

(ROUND .round) 

(SUM round 1 .nextround) 

(CURSOR WATSON 1 70) 

(P "ROUND") 

(CURSOR WATSON 2 70) 

(P " " .nextround) 

(ADDCL ((ROUND .nextround)) 1) 

(ADDCL ((HISTORY .nextround 

((" in round" .nextround "the following facts were deduced: )))) 1) 
(REQUEST _s _l _w) , , .. 

(OR ((IS-SOLUTION (_s .1 _w)) (SOLUTION-PRESENTED (_s .1 _w)) /) 
((REQUEST-PRESENTED (_s .1 _w)) 

(REQUEST-ANSWERED .pi _s .1 _w) 

(CUWIND WATSON) 

(CLOSE table) 

^ (PLAYED _p2))) 

(INMENU~^answer ("asking three cards" "giving suspicion") _p 2 0 30) 
(EXECUTED _p .answer) /) 

((BEGUN _p) 

(IS-PLAYERS-LIST _list) 

(INMENU p .list "Who starts the gome ?" 2 0 30) /) 

((CARDS-ASKED) 

(CRWIND table 0 10 22 58) 

(CURSOR table 20 1) 

(IS-PLAYERS-LIST (_p1|_rest)) 

(P .pi) 

(P " please show WATSON your cards ") 

(IS-SUSPECTS-LIST _sIIst) 

(APPEND (stop) _sIist .sstoplist) 

(SUSPECTS-ASKED .sstoplist) 

(IS-LOCATIONS-LIST .Mist) 

(APPEND (stop) .Mist .1 stop list) 

(LOCATIONS-ASKED .1 stop list) 

(IS-WEAPONS-LIST .wlist) 

(APPEND (stop) .wlist .wstoplist) 

(WEAPONS-ASKED .wstoplist) 

(CUWIND WATSON) 

(CLOSE table) /) 

((ADD-NEXT-NAME-TO .list .line) 

(R|.name) 

(OR ((EQ .name (stop)) /) 


(continued) 
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./) 


((APPEND _list .norne .newlist) 

(SUM 1 _line .newline) 

(DELCL ((IS-PLAYERS-L1ST .list))) 
(ADDCL ((IS-PLAYERS-LIST .newlist))) 
(CURSOR table .newline 0) 

(P " next player Is: ") 
(ADD-NEXT-NAME-TO .newllst .newline))) 


((PLAYER-NAMES-ASKED) 

(CRWIND table 0 10 22 58) 

(CURSOR table 1 0) 

(P " Give WATSON the names of the players ") 
(CURSOR table 2 0) 

(P " In order, beginning with the player") 
(CURSOR table 3 0) 

(P " who is using WATSON.") 

(CURSOR table 4 0) 

(P “ Avoid duplicate names and terminate") 
(CURSOR table 5 0) 

(P " name listing by typing <stop> 

(EQ .line 7) 

(CURSOR table .1ine 0) 

(P " user of WATSON: ") 

(IS-PLAYERS-LIST .list) 

(ADD-NEXT-NAME-TO .1ist line) 

(INMENU .option (" yes" " no") " 
(NAME-LISTING-ALLRIGHT .option) 

(CUWIND WATSON) 

(OR ((IS-PLAYERS-LIST (.pi _p2|_more))) 

((PROBLEM-IS-TRIVIAL))) 

(CLOSE table) /) 

((NAME-LISTING-ALLRIGHT " yes")) 
((NAME-LISTING-ALLRIGHT " no") 

(DELCL ((IS-PLAYERS-LIST .1ist))) 

(ADDCL ((iS-PLAYERS-LIST ()))) 

(CUWIND WATSON) 

(CLOSE table) 

(PLAYER-NAMES-ASKED) 

/) 

((PROBLEM-IS-TRIVIAL) 

(CLOSE table) 

8? 

2) (P 


”) 


names allright ?" 18 59 18) 


2 

3 

4 


"You don’t 
"with less 
"In this c< 


(CURSOR WATSON 
(CURSOR WATSON 
(CURSOR WATSON 
(STOP) /) 

((PCLAUSE (" in round" _i .heading)) 

(P "IN ROUND" _t .heading)) 

((PCLAUSE .clause) 

(IS-PLAYERS-LIST (_p1|_rest)) 

(ON .pi .clause) 

(NOT ON HAS .clause) /) 

((PCLAUSE (IS-IN-THE-BOX _c)) 

(P _c "is in the box")) 

((PCLAUSE (HAS _p _c)) 

(P _p " has" _c)) 

((PCLAUSE (HAS-NOT _p _c)) 

(P _p " has not" _c)) 

((PCLAUSE (HAS-NOT-ALL-THREE _p 

(P _p "has not" .cl _c2 _ _ 

((PCLAUSE (HAS-NOT-BOTH _p .cl _c2)) 

(P _p " has not both" .cl "and" c2)) 
((PCLAUSE (AT-LEAST-ONE-IS-IN-THE-BOX _s .1 _w)) 
(P "at least one of" _s .1 "and" _w "is 


need an expert when playing ") 

than two players!!") 

se you should work it out yourself.") 


_c1 _c2 _c3)) 
"and" _c3 "all 


three")) 


_c1 


.cl "and" _c2)) 
_s .1 _w)) 

1 _s .1 "and" 


((PCLAUSE (AT-LEAST-ONE-IS-IN-THE-BOX 
(P "at least one of" .cl "and" c2 "is 
((PCLAUSE (HAS-AT-LEAST-ONE _p _cl"_c2)) 

(P _p "has at least one of" 

((PCLAUSE (HAS-AT-LEAST-ONE _p 
(P _p "has at least one of 
((PCLAUSE .clause) 

(PCLAUSE-UNFORMATTED .clause) 

„ /) 

((PCLAUSE-UNFORMATTED (.atom|())) 

(P .atom) 

((PCLAUSE-UNFORMATTED (.atomll.restclause)) 


-C2)) 
in the 


in the box")) 
box")) 


_w)) 
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(P .otoml " ") 

(POLAUSE-UNFORMATTED _restclause) 

/) 

((PRCL _round .clause) 

(NEXT-FREE-PAGE .nextpage) 

(SUM 1 _poge .nextpage) 

(CHAROF .pagenome _page) 

(CURSOR .pagenome .row _col) 

(OR ((EQ _row 16) 

(CURSOR .pagenome _row 73) 

(P M ->") 

(CREATE-WINDOW _nextpage _newpogenome) 

(DELCL ((NEXT-FREE-PAGE _nextpage))) 

(SUM 1 _nextpoge _nextnewpage) 

(ADDCL ((NEXT-FREE-PAGE _nextnewpoge))) 
(CURSOR .newpagename 0 0) 

(P "ROUND " round "CONTINUED:") 

(PP)) 

((SUM 1 _row _nextrow) 

(CURSOR .pagename _nextrow 0))) 

(PCLAUSE .clause) 

((PAGE-TO " stop justifying") 

(CUWIND WATSON) 

((PAGE-TO " next window") 

(CUWIND .pagenome) 

(CHAROF .pagenome .page) 

(SUM _poge-prev 1 .page) 

(OR ((EQ _poge-prev 96)) 

((CHAROF _pagename-prev _page-prev) 

(CUWIND _pagename-prev))) 

(PAGING) 

((PAGE-TO " previous window") 

(CUWIND .pagenome) 

(CHAROF .pagenome .page) 

(SUM .page 1 .page-next) 

(NEXT-FREE-PAGE .upperbound) 

(OR ((EQ .page-next .upperbound)) 

((CHAROF _pagename-next .page-next) 

(CUWIND _pagenome-next))) 

(PAGING) 

/) 

((PAGING) 

(INMENU .option (" next window" " previous window 
" proven facts on " 18 50 25) 

(PAGE-TO .option) 

((GIVE-HISTORY-FACTS) 

(ADDCL ((NEXT-FREE-PAGE 97))) 

(FORALL ((ROUND _i)) 

((GIVE-HISTORY-PAGE _i))) 

(PAGING) 

/) 

((GIVE-HISTORY-PAGE .round) 

(NEXT-FREE-PAGE _poge) 

(CREATE-WINDOW .page .pagenome) 

(SUM 1 .page .nextfreepoge) 

(DELCL ((NEXT-FREE-PAGE .page))) 

(ADDCL ((NEXT-FREE-PAGE .nextfreepoge))) 

(CURSOR .pagenome 0 0) 

(FORALL ((HISTORY .round (.clause))) 

((PRCL .round .clause))) 

/) 

((CREATE-WINDOW .page .pagenome) 

(CHAROF .pagenome .page) 

(CRWIND .pagenome 0 0 17 78)) 


W 


stop justifying") 


{continued) 
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JE.MIC 

"The Art of Deduction," by J.C. Emond ond A. Paultssen, 
November 1986, page 207. 


((JUSTIFY " no")) 

((JUSTIFY " yes") 

(GIVE-HISTORY-FACTS)) 

((EXPL .card .type .1ine) 

(IS—IN-THE-BOX .cord) 

(CURSOR explanations .line 0) 

(P " I know that <" .card "> is in the box. So I don't need any") 

(SUM .1ine 1 .1inel) 

(CURSOR explanations _Iinel 0) 

(P " information about type <" .type ">i By asking <" card "> I") 

(SUM .1inel 1 .1ine2) 

(CURSOR explanations _line2 0) 

(P " force opponents to reveal Information about one of the”) 

(SUM .1ine2 1 .1ine3) 

(CURSOR explanations _line3 0) 

(P " other proposed cards. But if you like, you may ask any card") 

(SUM .1ine3 1 .1Ine4) 

(CURSOR explanations _IIne4 0) 

(P " of type <" .type "> you hold yourself instead of <" .card ">!") /) 
((EXPL .card .type .line) 

(CURSOR explanations .line 0) 

(P " I hove no conclusive information about card <" card ">. As far") 
(SUM .1ine 1 .1inel) 

(CURSOR explanations _Iinel 0) 

(P " as I know, it may be in the box. By asking <" card "> I will") 
(SUM .1Inel 1 .1ine2) 

(CURSOR explanations _line2 0) 

(P " find out about it or about 
(SUM .1 Ine2 1 .1ine3) 

(CURSOR explanations _line3 0) 

(P " cards I propose you to ask. 

((EXPLAINING " no"|_rest)) 

((EXPLAINING " yes" _s .1 _w) 

(CRWIND explanations 0 0 18 78) 


one of the other uncertain") 


’) /) 


(EXPL _s suspect 1) 
(EXPL .1 location 6) 
(EXPL _w weapon 11) 
(CURSOR explanations 
(P " Hit any key when 


17 0) 
you ’ re 


ready...“) 


>.-my key 

(GETB "TRM:" _x) 

(CUWIND table) 

(CLOSE explanations) /) 

((EXPLAIN _s .1 w) 

(INMENU .option (" no" " yes") 

(EXPLAINING .option s .1 w) /) 

((ADVISE-TO-SHOW .pi _s _w T) 

(HAS .pi _s) (HAS .pi _w) (HAS .pi .1) 
(ADVISE-TO-HIDE-LOCATION _s) 

((ADVISE-TO-SHOW .pi _s _w I) 

(HAS .pi _s) (HAS .pi .1) 
(ADVISE-TO-HIDE-LOCATION _s) 

((ADVISE-TO-SHOW .pi _s _w I) 

(HAS .pi _w) (HAS .pi .1) 
(ADVISE-TO-HIDE-LOCATION w) 

/) 

((ADVISE-TO-SHOW .pi _s _w I) 

(HAS .pi _s) (HAS .pi _w) 
(ADVISE-TO-SHOW-SYSTEMATICLY _s) 

((ADVISE-TO-SHOW .pi _s _w .1) 

(ON _x (_s _w .1)) 

(HAS .pi _x) 

(P "You must show" _x ".you have no choice") 
(TERMINATE) 

((ADVISE-TO-SHOW-SYSTEMATICLY _s) 


explain? " 17 50 12) 
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(P "WATSON advises you to show" _s) 

(CURSOR table 17 1) 

(P "because It Is sensible to show as far") 
(CURSOR table 18 1) 

(P "as possible always the some card.") 
(TERMINATE) 

/) 

((ADVISE-TO-HIDE-LOCATION _s) 

(P "WATSON advises you to show" _s) 

(CURSOR table 17 1) 

(P "because it is sensible to: ") 

(CURSOR table 18 1) 

(P "1. hide cords of the type location") 
(CURSOR table 19 1) 

(P "2. show always the same card if possible") 
(TERMINATE) 

((TERMINATE) 

(CURSOR table 21 1) 

(P "Hit any key to continue...") 

(GETB "TRM:" _x) 

(CUWIND WATSON) 

(CLOSE table) 

/) 


CC.MIC 

"The Art of Deduction," by J.C. Emond and A. Paulissen, 
November 1986, page 207. 


((CHECK ((HAS _p _c)) ) 

(NOT HAS-NOT _p _c) 

(fORALL ((PLAYER _p-other) (NOT EQ _p _p-other)) ((NOT HAS _p-other _c))) 
(OR ((HAS _p _c)) ((ADDCL ((HAS _p _c)) 1) 

(round _round) 

(ADDCL ((HISTORY _round ((HAS _p _c))))))) 

((CHECK ((IS-IN-THE-BOX _c)) ) 

(FORALL ((PLAYER _p)) ((NOT HAS _p _c))) 

(OR ((IS-IN-THE-BOX _c)) ((ADDCL ((IS-IN-THE-BOX _c)) 1) 


/) 


(ROUND _round) 

(ADDCL ((HISTORY _round ((IS-IN-THE-BOX _c))))))) 


((CHECK ((HAS-NOT-ALL-THREE _p _c1 _c2 _c3))) 

(IS-PLAYERS-L1ST (_p1|_rest)) 

(NOT ? ((HAS _p _c1) (HAS _p _c2) (HAS p _c3))) 

(OR ((HAS-NOT-ALL-THREE _p _c1 _c2 _c3)) 

((ADDCL ((HAS-NOT-ALL-THREE _p _c1 _c2 _c3)) 1) 

(ROUND _round) 

|(ADDCL Q ( (HISTORY .round ((HAS-NOT-ALL-THREE _p _c1 _c2 _c3))))))))) 

((CHECK ((HAS-NOT-BOTH _p .cl _c2))) 

(IS-PLAYERS-LIST (_p1|_rest)) 

(NOT ? ((HAS _p _c1) (HAS _p _c2))) 

(OR ((HAS-NOT-BOTH _p _c1 _c2)) ((ADDCL ((HAS-NOT-BOTH _p _c1 _c2)) 1) 

N " /'Druikjn PAim^ 


/) 


(ROUND .round) 

[(ADDCL°( (HISTORY .round ((HAS-NOT-BOTH _p .cl _c2))))))))) 


((CHECK ((HAS-AT-LEAST-ONE _p _s .1 _w))) 

(IS-PLAYERS-LIST (_p1|_rest)) 

(NOT ? ((HAS-NOT _p _s) (HAS-NOT _p .1) (HAS-NOT _p _w))) 

(OR ((HAS-AT-LEAST-ONE _p _s .1 _w)) 

((ADDCL ((HAS-AT-LEAST-ONE _p _s .1 _w)) 1) 

(ROUND .round) 

(OR ((EQ _p _p1)) 

((ADDCL (IhISTORY .round ((HAS-AT-LEAST-ONE _p _s .1 _w))))))))) 

((CHECK ((HAS-AT-LEAST-ONE _p .cl _c2))) 

(IS-PLAYERS-LSIT (_p1|_rest)) 


[continued) 
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(NOT ? ((HAS-NOT _p _c1) (HAS-NOT p c2))) 

(OR ((HAS-AT-LEAST-ONE p cl c2)) 

((ADDCL ((HAS-AT-LEAST-ONE _p _c1 _c2)) 1) 

(ROUND _round) 

OR ((EQ _p _p1)) 

((ADDCL ((HISTORY .round ((HAS-AT-LEAST-ONE _p _c1 _c2))))))))) 

((CHECK ((HAS-NOT _p _c))) 

(IS-PLAYERS-L1ST (_p1|_rest)) 

(NOT HAS _p _c) 

(OR ((HAS-NOT _p _c)) ((ADDCL ((HAS-NOT _p c)) 1) 


/) 


(ROUND .round) 

(OR ((EQ _p _ P 1)) 

((ADDCL ((HISTORY .round ((HAS-NOT _p c))))))))) 


((CHECK ((AT-LEAST-ONE-IS-IN-THE-BOX s I w))) 

(NOT ? ((PLAYER .pi) (HAS pi _s) 

(PLAYER _p2) (HAS _p2 .1) 

(PLAYER _p3) (HAS _p3 w))) 

(OR ((AT-LEAST-ONE-IS-IN-THE-BOX s I w)) 

((ADDCL ((AT-LEAST-ONE-IS-IN-THE-BOX _s .1 _w)) 1) 

(ROUND .round) 

^ (ADDCL ((HISTORY .round ((AT-LEAST-ONE-IS-IN-THE-BOX _s .1 _w))))))) 

((CHECK ((AT-LEAST-ONE-IS-IN-THE-BOX .cl _c2))) 

(NOT ? ((PLAYER .pi) (HAS .pi .cl) 

(PLAYER _p2) (HAS _p2 _c2))) 

(OR ((AT-LEAST-ONE-IS-IN-THE-BOX .cl c2)) 

((ADDCL ((AT-LEAST-ONE-IS-IN-THE-BOX .cl _c2)) 1) 

(ROUNO .round) 

^ (ADDCL ((HISTORY .round ((AT-LEAST-ONE-IS-IN-THE-BOX .cl _c2))))))) 

((CHECK (.clause)) (INCONSISTENCY clause) /) 

((INCONSISTENCY .clause) 

(CUWIND WATSON) 

(CURSOR WATSON 3 3) 

(P "Inconsistency detected !!!!!!!!!! ") 

(CURSOR WATSON 5 3) 

(P "Somebody has asked three cards s/he holds her/himself,") 

(CURSOR WATSON 63) 

(P "or gave false information (by mistoke or by intension).") 

(CURSOR WATSON 7 3) 

(P "WATSON cannot deal with Irrational behaviour !") 

(CURSOR WATSON 16 3) 

(p "The inconsistency was detected") 

(CURSOR WATSON 17 3) 

(P "by trying to process the clause:") 

(CURSOR WATSON 19 3) 

(PCLAUSE .clause) 

(INMENU .option (" no" " yes") “ justify ? " 17 40 13) 

(JUSTIFY .option) 

(STOP) /) 

((FINAL-CHECK _s .1 w) 

(NOT AT-LEAST-ONE-IS-IN-THE-BOX si II wl) 

/) - 

((FINAL-CHECK _s .1 w) 

(FORALL ((AT-LEAST-ONE-IS-IN-THE-BOX .si .11 _w1)) 

((INTERSECT (.si .11 _w1) (_s .1 _w)))) 


((FINAL-CHECK _s .1 _w) 

(INCONSISTENCY (Final check))) 
((INTERSECT (_x|_rest) .secondlist) 
(OR ((ON _x .secondlist)) 

((INTERSECT .rest .secondlist))) 
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GP.MIC 

"The Art of Deduction," by J.C. Emond and A. Paulissen, 
November 1986, page 207. 


((INMENU .select .menu .wind _startrow .startcol .width) 

(LST .menu) 

(NOT EQ .menu ()) 

(SUM _startrow .rows I eft 21) 

(STRINGOF ..window .wind) 

(splitmenu .rowsleft .menu .spltmenu) 

(showmenu .select () .spltmenu .window .startrow .startcol .width)/) 

((showmenu .select .oldmenus (.menul.rest) .wind .startrow .startcol .width) 

(CUWIND .curwind) 

(W .curwind ("~N")) 

(getwindname .oldmenus .rest .wind .window) 

(length-of .menu .menulen) 

(CRWIND .window .startrow .startcol .menulen .width 1 0) 

(W .window ("-]")) 

(CUWIND .curwind) 

(FORALL ((ON .entry .menu)) ((FWRITE .window ((CON .width)) (.entry)))) 

(peruse .window _sel .menu .width} 

(validselect .sel .oldmenus .rest) 

(CLOSE .window) 

(NOT EQ _seI "...break") 

(IF (EQ _seI "...next") 

((showmenu .select (.menu|_oIdmenus) .rest .wind .startrow .startcol .width)) 
((IF (EQ .sel ".. .prev") 

((EQ .oldmenus (.prevmenu|_oIdrest)) 

(showmenu .select .oldrest 

(.prevmenu .menu|.rest) .wind .startrow .startcol .width)) 

((EQ _seI .select)))))) 

((validselect "...next" .prevmenus .nextmenus) 

(NOT EQ .nextmenus ())) 

((validselect "...prev" .prevmenus .nextmenus) 

(NOT EQ .prevmenus ())) 

((validselectl.args)) 

((getwindname .prevmenu .nextmenu .wind .window) 

(extendname .prevmenu .nextmenu _ext) 

(APPEND .wind .ext .wind2) 

(STRINGOF .wind2 .window)) 

((extendname () () ())/) 

((extendname () (.i 


M II II 
II II II 


"+"))/) 

"-"))/) 


.menu l.rest) (" 

((extendname (.menul.rest) () (" 

((extendname .prevmenu .nextmenu (" " " " "-" "+"))) 
((splitmenu .numentries .menu (.submenu|.restmenu)) 

(split .numentries .menu .submenu .rest) 

(splitmenu .numentries .rest .restmenu)) 
splitmenu .numentries () ())/) 
splitmenu .numentries .menu (.menu))) 

((split 0 .menu () .menu) 

((split .numrows (.entl.restmenu) (_entl.reststart) .endmenu) 
(SUM .numrows-1 1 .numrows) 

(split .numrows-1 .restmenu .reststart .endmenu)) 


H 


((length-of () 0)) 
((length-of (_A|_B) _C) 
(length-of _B _D) 


(SUM _0 1 _C) 
((APPEND () _A _A) 
((APPEND (_A|_B) J 


) 


... . ,C (_A|_D)) 
(APPEND _B _C _D)) 

((peruse _A _B (_C|_D) _E) 

(CURSOR _A 0 0) 

(choose _A _8 (_C|_D) () _E)) 
((peruse|_A) 

(peruse|_A)) 


{continued) 
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((choose wind .select (_ent |.beIow) .above ..width) 

(IF (EOF "TRM: *') 

((FWRITE wind ((CON 3) (CON .width) (CON 1)) ("~]~M~R M .ent M ~D M )) 
(GETB "TRM:" .char) 

(FWRITE .wind ((CON 1) (CON .width) (CON 1)) ("~M M .ent M ~M"))) 
((GETB M TRM: M .char))) 

(pick .char .wind .select (.ent|.beIow) .above .width)) 

((choose | .args) 

(choose | _args)) 

((pick 13 .wind .ent (.ent|.be low) .above .width) 

(OR ((FWRITE .wind ((CON 2) (CON .width)) ("~M~B" _ent)) 

(handle-printer .wind)) 

((W .wind ( M ~N U )) 

(choose .wind .ent (_ent|.beIow) .above .width)))) 

((pick 45 .wind "...prev"|.rest)) 

((pick 43 .wind "... next"j.rest)) 

((pick 127 .wind "...break"l.rest)) 

((pick 80|_args) 

(movedownl.args)) 

((pick 32| .args) 

(movedownl.args)) 

((pick 24|_args) 

(movedownJ.args)) 

((pick 72|.args) 

(moveupl.args)) 

((pick 8|.args) 

(moveupl.args)) 

((pick 5|_args) 

(moveupl.args)) 

((pick 14 .windJ.rest) 

(change-printer off) 

FAIL) 

((pick 16 .windl.rest) 

(change-printer on) 

FAIL) 

((pick 15 .wind|.rest) 

(W .wind ( M ~0")) 

FAIL) 

((pick 23 .wind|.rest) 

(W .wind ("~W")) 

FAIL) 

((movedown .wind .select (.ent .nextent|.below) .above .width) 

(W .wind ("~J")) 

(choose .wind .select (.nextent|.beIow) (_entl.above) .width)) 

((movedownl.args) 

(choosel.args)) 

((moveup .wind .select .below (.preventl.above) .width) 

(W .wind ("~H~M")) 

(choose .wind .select (.prevent|.beIow) .above .width)) 

((moveupl.args) 

(choosel.args)) 

((printer off)) 

((change-printer .state) 

(KILL printer) 

(ADDCL ((printer .state)))) 

((handle-printer .wind) 

(IF (printer off) 

((W .wind ("~N"))) 

((W .wind (”~P"))))) 
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DIRDEMO.PAS 

"Using DOS Functions from Turbo Pascal," by Douglas f. Yriat, December, 1986, page 102. 


program DirectoryDemo; 

Demonstration of how to search a PC-DOS/MS-DOS file directory for 
a file specification, which can contain global characters ('** and '?’), 
using DOS function calls hex 4E and hex 4F. Displays a list of names 
and sizes of files which match the specification. 

Program compiles correctly under versions 2 and 3 of Turbo Pascal. 

Tested under IBM PC-DOS ver 2.10 and 3.0, and Compaq MS-DOS 2.11. 


Copyright June 1985 by D.F. Yriart. 

Sub-directory attribute test modified 28 July 1985. 


type 

UserSpec 

Registers 


FiIeName 

DTAPointer 

DTARecord 


« str1ng[64]; 

■ record 

AX,BX,CX,DX,BP,SI,DI.DS.ES,Flags : Integer; 
end; 

■ str1ng[13]; 

* '"DTARecord; 

■ record j Layout of DTA on return from calls } 

DOSReserved : array[1..21] of byte; 

Attribute : byte; 

FileTime, { packed in special format 

FileDate, | 

SizeLow, 

SIzeHigh ; integer; 

FoundName : array[1..13] of char; 

end; 


const 

NUL » | character 0, used to terminate ASCIIZ string 

SeekAttrlb » $10; } search for files k sub-directories 


var 


TransferRec 
MatchPtrn 
RetName 
FiISize 
Count 


DTAPointer; 
UserSpec; 

FiIeName; 
Rea I ; 
Integer; 


NoFind, LastFile, 

SubDirec : Boolean; 


will point to program DTA 
in Turbo Pascal string format 
name found by call 
size of file found 


procedure PointDTA(Var DTARec : DTAPointer); 

Use function hex 2F to locate the starting address of the Data 
Transfer Area (DTA) and point to it. 


Pointer will be used by file match procedures to find the data 
returned in the DTA. 

i 

Const GetDTA ■ $2F00; j function number } 


var 

Regs : Registers; 

Begin 

Regs.AX GetDTA; j load function number 
MsDos(Regs); \ make call to DOS 


(continued) 
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j On return from coll to GetDTA, ES register contains DTA segment 
address, BX register contains OTA offset In segment } 

DTARec Ptr(Regs.ES.Regs.BX); { Set pointer \ 

End; 

function SIzeOfFiIe(HI Word, LoWord ; Integer) ; Real; 

Converts the file size returned by DOS In two 16 bit words (unsigned 
integers) Into a real number. 


Var 

BigNo, Size : Real; 

Beg i n 

BigNo := (Maxlnt * 2.0) + 2; 

if HiWord < 0 then Size :« (BigNo + HiWord) * BigNo 
else Size :* HiWord * BigNo; 
if LoWord >« 0 then Size :• Size + LoWord 
else Size Size ♦ (BigNo + LoWord); 

SIzeOfFile Size 

End; 

procedure FindFirst(Pattern ; UserSpec; Var Found : FIleName; Var Size : Real; 
Var NoMatch : Boolean; Var LastOne : Boolean; 

Var SubDir ; Boolean); 

^ Function hex 4E returns first file name that matches user's specification. 

If an error occurs, the carry flag will be set and DOS will return error 
code 2 or 18 in the AX register. The procedure sets NoMatch and LastOne 
depending on the error code. 

The fllespec to search for must be stored as an ASCIIZ string, terminated 
by a byte of binary zeros (character NUL). When the call is made, the 
DS and DX registers point to the ASCIIZ string. 

The file attribute to search for can be loaded in the CX register. 

If a match occurs, the DTA will be loaded with information about 
the file which was found. This procedure recovers the file name and 
attribute of the found file. SubDir returns true if the file’s 
attribute is "subdirectory". 


Const FindFirst = $4E00; { function number \ 

Type 

ASCIIZ - array[1..64] of char; 


FileSpec ; ASCIIZ; { search pattern in DOS ASCIIZ string format \ 
Regs : Registers; 

PosInStr, 

Count : Integer; 

FoundLen : Byte absolute Found; 

Begin 

\ Convert the file name to an ASCIIZ string for the function call. \ 
for PosInStr :* 1 to Iength(Pattern) do 

F1 IeSpec[PosInStr] :* Pattern[PosInStr], 

FiIeSpec[Iength(Pattern) + 1] :« NUL; 

With Regs do 
beg i n 

DS :« SegfFileSpec); | Point to ASCIIZ string { 

DX :* Ofs(FileSpec); 

CX :* SeekAttrib; j File attribute to look for \ 

AX :* FindFirst; j load function number \ 

MsDos(Regs); 

if (Flags and 1) > 0 then j test carry flag \ 
begin J Handle error return codes \ 

Case AX of 

2 : begin { No match { 

NoMatch True; 
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LastOne := True; 
end; 

18 : begin { No more files } 

NoMotch := Folse; 

LostOne :* True; 
end; 

e I se 

wr 1 teIn(*G*Can'*t interpret error return code*); 
Halt; 

end; { Case } 

end 
e I se 

begin { No error return code } 

NoMatch :» False; 

LastOne ;■ False; 
end; 

end; j with Regs } 

J Capture returned file name and attribute, other information 
such as file size, time and date is also returned in the DTA. 
TransferRec points to the record superimposed on the DTA. } 

if (not NoMatch) then 
with TransferRec* do 
beg i n 

Found :* FoundName; 

$ Find number of characters returned in the file name area \ 
Count :* 0; 

While Found[Count] <> NUL do Count := Count + 1; 

FoundLen :■ Count; { set the length of the name string \ 

{ Blank out any garbage characters passed from the DTA } 

For Count Iength(Found) + 1 to 13 do Found :* Found + ’ '; 

j Test whether the file is a subdirectory and set flag. { 
if (Attribute and SeekAttrib) > 0 then SubDir :■ True 
eIse SubDir :■ Fa Ise; 

\ Get the file size if file is not a subdirectory. { 

If not SubDir then Size SizeOfF?Ie(SizeHigh,SizeLow) 
else Size :* 0.0; 

end; j with TransferRec \ 

End; 

procedure FindNext(Var Found : FileName; Var Size : Real; 

Var LastOne : Boolean; Var SubDir : Boolean); 

Function hex 4F returns next matching file name. When error 18 is 
returned there are no more matches. The search criteria set up by 
function hex 4E are used by this call, and information is returned 
In the DTA as described for procedure FindFirst. 


Const FindNext ■ $4F00; { function number \ 

var 

Regs : Registers; 

Count : Integer; 

FoundLen : Byte absolute Found; 

Begin 

With Regs do 
begin 

AX FindNext; 

MsDos(Regs); 

If (Flags and 1) > 0 then { Handle error return codes j 
If AX ■ 18 then LastOne True { No more files j 

e I se 

begin 

wrlteIn(*G*Can'*t interpret error return code*); 
Halt; 

end 

else LastOne False; j No error return code \ 
end; { with Regs \ 


( continued ) 
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{ Capture returned file name and attribute \ 

with TronsferRec* do 

begin 

Found :■ FoundName; 

| Set length of file name and clear "garbage." } 

Count :■ 0; 

While Found[Count] <> NUL do Count :■ Count + 1; 

FoundLen :» Count; 

For Count Iength(Found) + 1 to 13 do Found :■ Found + * •; 

{ Test for subdirectory. } 

if (Attribute and SeekAttrib) > 0 then SubDir :« True 
eIse SubDir :*» Fa I se; 

\ Get the file size if file is not a subdirectory. } 
if not SubDir then 

Size SizeOfFile(SizeHlgh.SizeLow) 
else Size :« 0.0; 

end; J with TransferRec } 

End; 

i 

********************************** 

* MAIN PROGRAM * 

********************************** 

I 

BEGIN 

Cl rScr; 

writeln(* — Demonstration of Directory Search Calls —'); 
write(' Find? '); 

read In(MatchPtrn); j The user’s search specification \ 
wr iteIn; 

Count :■ 0; 

PointDTA(TransferRec); { Set the DTA pointer } 

| Call function hex 4E to search for first match. } 

FindFirst(MatchPtrn,RetName,FiISize.NoFind.LastFiIe.SubDirec); 

if NoFind or LastFile then writeIn(*FiIe not found.') 

e I se 
beg i n 

\ Display additional matches and keep looking until no 
more are found. Display in three columns. \ 

While (not LastFile) do 
beg i n 

If SubDirec then LowVideo; j Display subdirectories in \ 
wrlte(RetName,• •,FiISize:8:0,' '); J low intensity. } 

NormVideo; 

Count :» Count + 1; 

if (Count mod 3) = 0 then Writeln; 

j Call function hex 4F to search for another match. } 

FindNext(RetName,FiISize.LastFiIe,SubDirec); 

end; 

end; 

{ Close up the display with a count of files found. } 

if (Count mod 3) <> 0 then writeln; 

writeln; 

write('*** '.Count,* Files or '); 

LowVideo; 

wr i te('Sub-Directories'); 

NormVideo; 

writeln(' found ***•); 

END. 
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AITKEN.F77 

"A Program for Approximating Integrals," by David M. Smith, December, 1986, page 113. 


PROGRAM GAUSS 
C 

C FORTRAN-77 PROGRAM TO APPROXIMATE DEFINITE INTEGRALS. VERSION: 4-14-86 
C 

C DAVID M. SMITH 
C MATHEMATICS DEPARTMENT 
C LOYOLA MARYMOUNT UNIVERSITY 
C LOS ANGELES, CA 90045 
C 
C 

IMPLICIT DOUBLE PRECISION (A-H.O-Z) 

DIMENSION TABLE(20) 

C 

C UNIT NUMBERS: KW - SCREEN OUTPUT 

C KR - KEYBOARD INPUT 

C KF - OUTPUT TO FILE ’GAUSSQ.OUT* 

C 

KW - 6 
KR - 5 
KF = 8 

OPEN(KF,FILE«*GAUSSQ.OUT*,STATUS-’NEW *) 

C 

C FORTRAN-77 COMPILERS ALLOW THESE 5 INPUT VALUES TO BE 

C ENTERED IN FREE FORMAT. I.E., TO ENTER NFCT = 2 TYPE THE 

C 2 IN COLUMN 1 AND THEN TYPE CARRIAGE RETURN. TO ENTER 

C A - 1 TYPE 1. OR 1.0 THEN RETURN. THE DECIMAL POINT 

C SHOULD BE TYPED FOR THE REAL VALUES (A AND B). 

C 

C MOST FORTRAN-66 COMPILERS WHICH SUPPORT IF-THEN-ELSE 

C REQUIRE THAT THE INTEGERS BE TYPED RIGHT-JUSTIFIED, 

C SO THAT TO ENTER NFCT - 2 TYPE 4 BLANKS AND THEN THE 2 

C IN COLUMN 5. 

C 

110 WRITE (KW,120) 

120 FORMAT(/* Enter (1 item per line): NFCT / KL / IOFLAG / A / B.* 

* /7X,*(Format for NFCT,KL,IOFLAG is 15, for A,B is F25.0.*/ 

* /’ Integrate function NFCT from A to B (NFCT-0 to quit)*, 

* /* There will be KL lines in the Gauss*, 

* * column of the table.*/ 

* ’ IOFLAG - 1 causes the output to be saved in file’, 

* * GAUSSQ.OUT.*/) 

C 

READ (KR,130) NFCT 
130 FORMAT(15) 

IF (NFCT.EQ.0) STOP 
READ (KR,140) KL.IOFLAG,A,B 
140 FORMAT(I5/I5/F25.0/F25.0) 

C 

IF (NFCT.LE.0) STOP 
C 

KPRT » 1 

IF (IOFLAG.EQ.1) KPRT - 2 

CALL GAUSSQ(A,B,NFCT.KL,TABLE.KPRT,KF,KW) 

DO 170 J = 1, 20 
WRITE (KW,150) 

150 FORMAT(/*'ENTER 1 FOR THE NEXT AITKEN COLUMN, 0 TO QUIT.’, 

* * (II)') 

READ (KR,160) KOPT 

160 FORMAT(II) 

IF (KOPT.NE.1) GO TO 110 

CALL AITKEN(TABLE.KL.KPRT.KF.KW) 

KL - KL - 2 
IF (KL.LT.3) GO TO 110 
170 CONTINUE 

GO TO 110 
C 

END 

SUBROUTINE GAUSSQ(A.B,NFCT.KL.TABLE.KPRT,KF,KW) 

IMPLICIT DOUBLE PRECISION (A-H.O-Z) 
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DAVID M. SMITH 4-14-86 

ITERATIVE GAUSS QUADRATURE. FUNCTION NUMBER NFCT IS INTEGRATED FROM 
A TO B PRODUCING KL LINES IN TABLE USING 
1, 2. 4 , 8, 16.2**(KL-1) SUBINTERVALS. 

IF KPRT IS 1 THE TABLE IS WRITTEN ON UNIT KW. 

IF KPRT IS 2 THE TABLE IS ALSO WRITTEN ON UNIT KF. 

IN THE TABLE WHICH IS WRITTEN: 

N IS THE NUM8ER OF SUBINTERVALS USED. 

GAUSS IS THE GAUSS QUADRATURE APPROXIMATION TO THE INTEGRAL, 

TOTAL NF IS THE TOTAL NUMBER OF FUNCTION EVALUATIONS DONE SO FAR, 

EST S.D. IS A CONSERVATIVE ESTIMATE OF THE NUMBER OF SIGNIFICANT 
DIGITS WHICH ARE CORRECT IN THAT LINE 

THE EXTERNAL FUNCTION CALLED IS F(X.NFCT) FOR THE FUNCTION BEING 
INTEGRATED. 

DIMENSION TABLE(20) 

SET EPS TO THE SIZE OF THE ROUNDING ERRORS FOR A GIVEN 
MACHINE. EPS - 1.0E-7 FOR 32 BIT MACHINES (SINGLE 
PRECISION) OR 1.0E-16 (DOUBLE PRECISION). 

EPS = 1.0E-16 

CHECK FOR ERRORS. 

IF (KL.LT.1) THEN 

WRITE (KW,110) KL 

110 FORMAT(/’ ERROR IN GAUSSQ. KL-’,I5,’. IT SHOULD BE AT ’, 

* ’LEAST 1.’) 

DO 120 J = 1, 20 
120 TABLE(J) - -3.1E+31 

RETURN 
ENDIF 


DO GAUSS QUADRATURE FOR THE INTEGRAL OF F(X) FROM A TO B. 

NLINES - KL 

SQRT3 - DSQRT(3.0D0) 

NSUBS - 1 
NFUNCT - 0 

IF (KPRT.GE.1) THEN 

WRITE (KW,130) NFCT.NLINES 
IF (KPRT.GE.2) WRITE (KF.130) NFCT,NLINES 
130 FORMAT(/' GAUSS INTEGRATION OF FUNCTION ’,13/. THERE’, 

* ’ ARE’,13,’ LINES IN THE TABLE.’) 

WRITE (KW,140) A.B 

IF (KPRT.GE.2) WRITE (KF.140) A.B 
140 FORMAT(/’ THE LIMITS OF INTEGRATION ARE:’/3X.D23.16. 

* ’ TO ’,D23.16/) 

ENDIF 


DO 180 JLINE - 1. NLINES 

THE KTH SUBINTERVAL IS (AK.BK). THE GAUSS APPROXIMATION 
FOR THE INTEGRAL IS: XH*(F(XM-XR) + F(XM+XR)), WHERE 
XH « (BK-AK)/2, XM « (AK+BK)/2, XR = XH/(2*SQRT(3)). 
AK = A + (K-1 )*(B-A)/NSUBS, BK » A + K*(B-A)/NSUBS. 

XH = (B-A)/NSUBS 
XH2 - XH/2.0 
XR = XH2/SQRT3 
START1 - A - XH2 - XR 
START2 « A - XH2 + XR 
SUM = 0.0 
C 

DO 150 K - 1, NSUBS 
C 

150 SUM - SUM + F(START1+K*XH,NFCT) + F(START2+K*XH,NFCT) 

C 

SUM » SUM*XH2 
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NFUNCT = NFUNCT + 2*NSUBS 
IF (KPRT.GE.1) THEN 

IF (JLINE.LE.1) THEN 

WRITE (KW,160) NSUBS.SUM,NFUNCT 
IF (KPRT.GE.2) WRITE (KF.160) NSUBS,SUM,NFUNCT 
160 FORMAT(’ N ,16,* GAUSS-*,D23.16, 1 TOTAL NF-*,15) 

ELSE 

RELERR * EPS 

IF (SUM.NE.0.0) RELERR = DABS(TABLE(JLINE-1)-SUM) 

* / DABS(SUM) 

IF (SUM.EQ.0.0 .AND. TABLE(JLINE-1).NE.0.0) RELERR = 

* DABS(TABLE(JLINE-1)-SUM) / DABS(TABLE(JLINE-1)) 

IF (RELERR.LE.0.0) RELERR = EPS 

NUMSD - -DLOG10(RELERR) 

IF (NUMSD.LT.0) NUMSD = 0 
WRITE (KW,170) NSUBS,SUM,NFUNCT,NUMSD 
IF (KPRT.GE.2) WRITE (KF.170) NSUBS,SUM,NFUNCT,NUMSD 
170 FORMAT(* N =*.16,* GAUSS-’,D23.16,* TOTAL NF-*,15, 

* ’ EST S.D.-M3) 

ENDIF 

ENDIF 

C 

NSUBS - 2*NSUBS 
TABLE(JLINE) - SUM 
180 CONTINUE 
C 

RETURN 
END 

SUBROUTINE AITKEN(TABLE,KL,KPRT,KF , KW) 

IMPLICIT DOUBLE PRECISION (A-H.O-Z) 

DAVID M. SMITH 4-14-86 

AITKEN EXTRAPOLATION. THE VALUES TABLE(1) TO TABLE(KL) ARE USED FOR 
THE EXTRAPOLATION AND THE RESULTS ARE RETURNED IN TABLE(1) TO 
TABLE(KL-2). KL MUST BE AT LEAST 3. 

IF KPRT IS 1 THEN THE KL-2 VALUES ARE WRITTEN ON UNIT KW. 

IF KPRT IS 2 THE TABLE IS ALSO WRITTEN ON UNIT KF. 

IN THE TABLE WHICH IS WRITTEN: 

LINE IS THE LINE NUMBER, 

AITKEN IS THE AITKEN EXTRAPOLATION APPROXIMATION TO THE INTEGRAL, 
USING 3 VALUES FROM THE PREVIOUS COLUMN. FOR EXAMPLE. 

LINE 1 OF AN AITKEN COLUMN USES LINES 1-3 OF THE PREVIOUS 
COLUMN, LINE 4 USES LINES 4-6, ETC. 

EST S.D. IS A CONSERVATIVE ESTIMATE OF THE NUMBER OF SIGNIFICANT 
DIGITS WHICH ARE CORRECT IN THAT LINE 

DIMENSION TABLE(20) 

SET EPS TO THE SIZE OF THE ROUNDING ERRORS FOR A GIVEN 
MACHINE. EPS = 1.0E-7 FOR 32 BIT MACHINES (SINGLE 
PRECISION) OR 1.0E-16 (DOUBLE PRECISION). 

EPS = 1.0E-16 

IF (KL.LT.3) THEN 

WRITE (KW 110) KL 

110 FORMAT(//’ ERROR IN AITKEN. KL-*,I5,* IS LESS THAN 3.’/) 
RETURN 
ENDIF 
C 

IF (KPRT.GE.1) THEN 
KLM2 -KL-2 
WRITE (KW,120) KLM2 
IF (KPRT.GE.2) THEN 

IF (KLM2.GT.1) THEN 

WRTTF (KF 1901 KLM2 

120 FORMAT(/* AITKEN COLUMN.14,* ENTRIES.*/) 

ELSE 

WRITE (KF,130) KLM2 

130 FORMAT(/* AITKEN COLUMN. \ 14,* ENTRY.*/) 

ENDIF 


(continued) 
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c 


c 


c 


c 

c 


ENDIF 

ENDIF 


KLM1 » KL - 1 

DO 160 JUNE - 2, KLM1 

TOP - (TABLE(JLINE+1) - TABLE(JUNE))**2 

BOT - TABLE( JUNE+1) - 2.0*TABLE( JUNE) + TABLE(JUNE-1) 

IF (BOT.EQ.0.0) THEN 

TABLE(JUNE-1) - TABLE(JUNE+1) 

ELSE 

TABLE(JLINE-1) - TABLE(JUNE+1 ) - TOP/BOT 
ENDIF 


140 


* 

* 


150 

* 


IF (KPRT.GE.1) THEN 
JLM1 - JUNE - 1 
IF (JLINE.LE.2) THEN 

WRITE (KW,140) JLM1,TABLE(JLM1) 

IF (KPRT.GE.2) WRITE (KF.140) JLM1,TABIE(JLM1) 

FORMAT(’ LINE*.13,' AITKEN-’,D23.16) 

ELSE 

RELERR ■ EPS 

IF (TABLE(JLM1).NE.0.0) RELERR - DA8S(TABLE(JLM1-1) - 

TABLE(JLM1))/OABS(TABLE(JLM1)) 
IF (TABLE(JLM1).EQ.0.0 .AND. TABLE(JLM1-1).NE.0.0) 
RELERR = DABS(TABLE(JLM1-1)-TABLE(JLM1)) / 
DABS(TABLE(JLM1-1)) 

IF (RELERR.LE.0.0) RELERR - EPS 
NUMSD = -DLOG10(RELERR) 

IF (NUMSD.LT.0) NUMSD - 0 

WRITE (KW,150) JLM1,TABLE(JLM1),NUMSD 

IF (KPRT.GE.2) WRITE (KF.150) JLM1.TABLE(JLM1).NUMSD 

FORMAT(’ LINE*.13.’ AITKEN-’.D23.16. 

• EST S.D.-M3) 

ENDIF 

ENDIF 


160 CONTINUE 

RETURN 

END 

FUNCTION F(X.NFCT) 


COMPUTE F(X) FOR FUNCTION NUMBER NFCT. 

THIS CALLING SEQUENCE ALLOWS MANY DIFFERENT FUNCTIONS TO BE USED 
EASILY DURING ONE RUN. 

IMPLICIT DOUBLE PRECISION (A-H.O-Z) 

IF NFCT IS OUTSIDE THE RANGE OF CURRENTLY DEFINED 
FUNCTIONS THEN RETURN THE FUNCTION VALUE -9.9E+20. 

ANY OUTPUT TABLES CONSISTING ENTIRELY OF THIS VALUE ARE 
ALMOST CERTAINLY CAUSED BY SENDING THE WRONG VALUE OF 
NFCT. 


F - -9.9E+20 

IF (NFCT.LT.1 .OR. NFCT.GT.6) RETURN 
GO TO (1.2.3.4.5.6),NFCT 

1 F - DSQRT(DEXP(X)-1.0D0)/DSIN(X) 
RETURN 

2 F - DABS(X-0.3)**0.33333 
RETURN 


THIS FUNCTION IS 1/(X**4 + X**2 + 1) 
THE FORM USED BELOW EXECUTES FASTER. 

3 F - 1.0/((X*X+1)*X*X + 1) 

RETURN 

C 

4 T * X*X + 1.0 

F - T/(T*X*X + 1) 

RETURN 

C 
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5 F = DSQRT(X)/(X - 1.0) - 1.0/DLOG(X) 
RETURN 

C 

6 F * 2.0*X*X/((X-1.0)*(X+1.0)) - X/DLOG(X) 
RETURN 


C 


END 


AITKEN.BAS 


"A Program for Approximating Integrals," by David M. Smith, December, 1986, page 113. 


100 DEFDBL A-H,1,0-2 

110 REM Use EPS-1E-6 if functions are single precision. 
120 EPS*IE-10 
130 $QT3-SQR(3) 

140 DIM TABLE(20) 

150 LG10**LOG( 10) 

160 DEE FNL10(X)-LOG(X)/LG10 
170 F$-"f(x)=SQR(EXP(x)-1)/SIN(x)" 

180 DEF FNF(X)-SQR(EXP(X)-1)/SIN(X) 

_____ II 



ffirwwmr wwwnn-mrnwinnrwnw wirw 
230 PRINT "Approximating the integral of the function: 
240 PRINT " F$ 


250 INPUT "Number of lines in Gauss column (>1)";KL 
260 INPUT "Lower limit for Integra I“;A 
270 INPUT "Upper limit for lntegral";B 

280 IF B<»A THEN PRINT "Error. Lower limit <« upper limit.": STOP 

290 PRINT 

300 GOSUB 410 

310 PRINT 

320 FOR J-1 TO 20 

330 INPUT "Enter 1 for next Aitken column, 0 to quit";CQ 

340 IF CQ-0 THEN J-20: GOTO 390 

350 GOSUB 760 

360 PRINT 

370 KL-KL-2 

380 IF KL<3 THEN J-20 

390 NEXT J 

400 END 

410 IF KL<1 THEN PRINT "Error in Gauss subroutine: KL<1.“: STOP 
420 NLINES-KL 
430 NSUBS-1 
440 NFUNCT-0 

450 PRINT "Gaussian integration table for the function" 

460 PRINT F$; ", for x- ";A; " to ";8;"." 

470 PRINT "Table contains ";NLINES; " lines." 

480 PRINT 

490 FOR JLINE-1 TO NLINES 
500 XH-(B-A)/NSUBS 
510 XH2-XH/2 
520 XR-XH2/SQT3 
530 START1-A-XH2-XR 
540 START2-A-XH2+XR 
550 SUM-0 

560 FOR K-1 TO NSUBS 

570 SUM-SUM+FNF(START 1+K*XH)+FNF(START2+K*XH) 

580 NEXT K 

590 SUM-SUM*XH2 

600 NFUNCT-NFUNCT+2»NSUBS 

610 IF JLINE>1 THEN 650 

620 PRINT " N Gauss NF Est.S.D." 

630 PRINT USING T1$; NSUBS.SUM,NFUNCT 
640 GOTO 720 
650 RELERR-EPS 

660 IF SUMO0 THEN RELERR-ABS(TABLE(JLINE-1)-SUM)/ABS(SUM) 

670 IF SUM-0 AND TABLE(JLINE-1)<>0 THEN RELERR-ABS(TABLE(JLINE-1)-SUM)/ABS(TABLE(JLINE-1)) 
680 IF RELERR<«0 THEN RELERR-EPS 
690 NUMSD—FNL10 (RELERR ) 


[continued] 
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700 IF NUMSD<0 THEN NUMSD-0 

710 PRINT USING T2$;NSUBS,SUM,NFUNCT,NUMS0 

720 NSUBS-2*NSUBS 

730 TABLE(JLINE)-SUM 

740 NEXT JLINE 

750 RETURN 

760 IF KL<3 THEN PRINT "Error In Altken: KL<3.": STOP 
770 KLM2-KL-2 

780 PRINT: PRINT "Altken column. ";KLM2;" entries." 

790 PRINT: PRINT " Line Altken Est.S.D. 

800 KLM1-KL-1 

810 FOR JLINE-2 TO KLM1 

820 TOP-(TABLE(JLINE+1)-TABLE(JLINE))"2 

830 BOT-TABLE(JLINE+1)-2*TABLE(JLINE)+TABLE(JLINE-1) 

840 IF BOT-0 THEN TABLE(JLINE-1)-TABLE(JLINE+1) ELSE TABLE(JLINE-1)-TABLE(JLINE+1)-TOP/BOT 
850 JLM1-JLINE-1 

860 IF JLINE<-2 THEN PRINT USING T3$;JLM1,TABLE(JLM1): GOTO 940 
870 RELERR-EPS 

880 IF TABLE(JLM1)<>0 THEN RELERR-A8S(TA8LE(JLM1-1)-TABLE(JLM1))/ABS(TABLE(JLM1)) 

890 IF TABLE(JLM1)-0 AND TABLE(JLM1-1)<>0 THEN 

RELERR-ABS(TABLE(JLM1-1)-TABLE(JLM1))/ABS(TABLE(JLM1-1)) 

900 IF RELERR<=0 THEN RELERR-EPS 
910 NUMSD—FNL10(RELERR) 

920 IF NUMSD<0 THEN NUMSD-0 

930 PRINT USING T4$;JLM1;TABLE(JLM1);NUMSD 

940 NEXT JLINE 

950 RETURN 


BLAST.BAS 

"Local Effects of Nuclear Weapons," by John Fanchi, December, 1986, page 143. 


10 REM LISTING 1 

20 REM 

30 REM NUCLEAR BLAST CALCULATION 

40 REM (C) JOHN R. FANCHI, JUNE 1985 

50 REM MICROSOFT BASIC FOR CP/M-80 OPERATING SYSTEM 

60 REM PART OF THIS CODE IS EXCERPTED FROM J.R. FANCHI'S 

70 REM ADVENTURE SIMULATION GAME "NUCLEAR SURVIVAL" 

80 REM CHR$(26) CLEARS THE SCREEN 
90 DIM ANSER$(2) 

100 PRINT CHR$(26) 

110 PRINT TAB(20); "*** NUCLEAR BLAST CALCULATION ***" 

120 PRINT 

130 PRINT TAB(21);"(C) John R. Fanchi, JUNE 1985" 

140 PRINT 

150 PRINT "The calculations performed here are based on information published" 
160 PRINT "by the American Institute of Physics." 

170 PRINT 

180 INPUT "HIT CARRIAGE RETURN WHEN YOU ARE READY TO PROCEED";ICAR$ 

190 PRINT CHR$(26) 

200 PRINT 

210 INPUT "Specify your slant range (distance) from the blast in miles";D 
220 PRINT 

230 REM .DETERMINE WEAPON YIELD (Y) 

240 PRINT "Specify the yield of the blast in megatons. Typical values range" 
250 INPUT "from 0.8 to 20 megatons";Y 

260 REM .DETERMINE BLAST HEIGHT 

270 PRINT 

280 INPUT "Specify the height of the blast in feet";H 
290 PRINT 

300 PRINT "Specify the thermal energy fraction. This is the fraction of heat" 

310 PRINT "energy in the nuclear fireball. It should be between 0 and 1. A" 

320 INPUT "typical value is 0.35";TEF 
330 PRINT 

340 REM .DETERMINE TRANSMISSION FACTOR 

350 PRINT "Specify the atmospheric transmission factor. It should be between" 

360 INPUT "0 (very cloudy day) and 1 (perfectly clear day)"; TAU 

370 PRINT 

380 REM .CALC BLAST EFFECTS 

390 REM THERMAL FLUX Q 
400 Q-3000*TEF*TAU*Y/(D*D) 

410 REM BLAST OVERPRESSURE P 
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420 Z=(Y~(.333))/D 

430 P«22.4*(Z~3) + 15.8*(Z'"(1.5)) 

440 REM EMP RANGE 

450 EMP=SQR(2*H*3963/5280) 

460 REM RADIATION DOSAGE REM 

470 REMS-250*1000*Y/(16*3.1416*D*D) 

480 PRINT 

490 PRINT "The NUCLEAR BLAST hod the following effects:" 

500 PRINT , „ 

510 PRINT TAB(10);"THERMAL FLUX (col/sq cm)";TAB(50);Q 
520 PRINT TAB( 10)‘."OVERPRESSURE (lb/sq in)" ;TAB(50) ;P 
530 PRINT TAB(10);"EMP RANGE (mi Ies)";TAB(50);EMP 
540 PRINT TAB(10);"RADIATION DOSAGE (rems)";TAB(50);REMS 

560 INPUT "HIT CARRIAGE RETURN WHEN YOU ARE READY TO PROCEED";ICAR$ 

570 PRINT CHR$(26) 

580 PRINT 

590 rem .OVERPRESSURE EFFECTS 

600 IF P<20THEN 640 

610 PRINT "Overpressure has caused winds in excess of 500 miles per hour. 

620 PRINT "Even multi-story reinforced concrete buildings are leveled. 

630 GOTO 820 
640 REM 

650 IF P<10 THEN 700 , . , 

660 PRINT "Overpressure has caused winds in excess of 300 miles per hour. 

670 PRINT "Most factories and commercial buildings are leveled, as are small" 
680 PRINT "wood and brick residences." 

690 GOTO 820 
700 REM 

710 IF P<5 THEN 750 f fl . 

720 PRINT "Overpressure has caused winds in excess of 160 miles per nour. 

730 PRINT "Unreinforced brick and wood houses are leveled. 

740 GOTO 820 
750 REM 

760 IF P<2 THEN 790 , ^ f . 

770 PRINT "Overpressure has caused winds in excess of 70 miles per hour. 

780 GOTO 820 
790 REM 

800 PRINT "Overpressure has not had a significant effect on wind conditions 
810 PRINT "or the structures of buildings." 

820 REM 

830 PRINT rcrr - T 

840 REM .THERMAL EFFECT 

850 IF Q<10 THEN 880 

860 PRINT "Thermal flux has burned you to a crisp." 

870 GOTO 980 

port RFM 

890 IF Q<5 THEN 920 TwrRMAI FI 1IY " 

900 PRINT "You have suffered third degree burns because of THERMAL FLUX. 

910 GOTO 980 
920 REM 

930 IF Q<1 THEN 960 , . TUCDUA1 rlllv .. 

940 PRINT "You have suffered second degree burns because of THERMAL i-lux. 

950 GOTO 980 
960 REM 

970 PRINT "THERMAL FLUX has added to your ton. 

990 ET. .RADIATION EFFECTS PRINT 

1000 PRINT 

1010 IF REMS<5000 THEN 1050 . . 

1020 PRINT "You are experiencing convulsions, tremors and ataxia because 
1030 PRINT "of RADIATION exposure. No treatment will help you." 

1040 GOTO 1330 
1050 REM 

1060 IF REMS<1000 THEN 1120 , . . M 

1070 PRINT "You have diarrhea, fever and a disturbance of your body 
1080 PRINT "chemistry because of RADIATION exposure. Treatment may" 

1090 PRINT "alleviate pain, but it will not save your life. 

1100 
1110 


You have" 


live. 


PRINT "less than 2 weeks to 
GOTO 1330 

1120 REM 

1130 IF REMS<600 THEN 1190 , , , „ 

PRINT "You have very severe leukopenia and internal bleeding. 

PRINT "You have also developed ulcers and infection is likely because" 
PRINT "of RADIATION exposure. You need hospitalization but none is" 
PRINT "available, therefore you have less than a month to live." 


1140 

PRINT 

1150 

PRINT 

1160 

PRINT 

1170 

prin; 


( continued ) 
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1180 GOTO 1330 

1190 REM 

1200 IF REMS<200 THEN 1250 

1210 PRINT "Your symptoms range from leukopenia to hair loss because of" 

1220 PRINT "RADIATION exposure. Hospitalization is required and Is" 

1230 PRINT "available to you because you have a reasonable chance to live." 

1240 GOTO 1330 

1250 REM 

1260 IF REMS<100 THEN 1310 

1270 PRINT "RADIATION exposure has made you sick—vomiting, headache, some" 
1280 PRINT "loss of white blood cells and dizziness. This is good. You" 

1290 PRINT "will completely recover." 

1300 GOTO 1330 

1310 REM 

1320 PRINT "You have survived RADIATION exposure with NO effects." 

1330 PRINT 

1340 REM .EMP EFFECT 

1350 IF D>EMP THEN 1410 

1360 PRINT "Your distance from the blast is within the range of the " 

1370 PRINT "electromagnetic pulse (EMP). The EMP is capable of burning" 

1380 PRINT "out electrical instruments." 

1390 PRINT 
1400 GOTO 1440 
1410 REM 

1420 PRINT "You are outside the range of the electromagnetic pulse (EMP)." 

1430 PRINT 
1440 PRINT 

1450 INPUT "Do you wish to try again (Y/N)";IANS$ 

1460 PRINT 

1470 IF IANS$«"Y" THEN 100 
1480 SYSTEM 
1490 END 


FALOUT.BAS 

"Local Effects of Nuclear Weapons," by John Fanchi, December, 1986, page 143. 


10 REM LISTING 2 

20 REM 

30 REM FALOUT - A NUCLEAR FALLOUT CALC PROGRAM 
40 REM (C) JOHN R. FANCHI, JULY 1985 
50 REM MICROSOFT BASIC ON CP/M-80 OPERATING SYSTEM 
60 REM CHR$(26) CLEARS SCREEN 
70 PRINT CHR$(26) 

80 PRINT " FALOUT - ESTIMATING THE DISTRIBUTION OF NUCLEAR FALLOUT" 

90 PRINT 

100 PRINT "(C) J.R. FANCHI, JULY 1985 

110 PRINT: PRINT: PRINT 

120 PRINT "ESTIMATING RADIATION DOSAGE" 

130 PRINT 

140 INPUT "ENTER THE YIELD OF THE NUCLEAR BLAST IN MEGATONS: ", Y 
150 PRINT 

160 INPUT "ENTER YOUR DISTANCE FROM THE BLAST IN MILES: ", D 
170 PRINT 

180 REMS-250*1000*Y/(16*3.1416*D*D) 

190 PRINT "ESTIMATED RADIATION DOSAGE IN REMS: ",REMS 
200 PRINT 

210 PRINT: PRINT: PRINT 

220 PRINT "ESTIMATING FALLOUT DISTRIBUTION" 

230 PRINT 

240 PRINT "THE DISTRIBUTION OF FALLOUT IS TREATED AS A RANDOM WALK PROCESS" 
250 PRINT "SIMILAR TO BROWNIAN MOTION." 

260 PRINT 

270 INPUT "ENTER THE LINE-OF-SIGHT WIND SPEED (MPH): ",VPAR 
280 VPAR-VPAR*24! 

290 PRINT 

300 INPUT "ENTER THE LINE-OF-SIGHT DISPERSION (SQ MILES/D): ",DPAR 
310 PRINT 

320 INPUT "ENTER THE TRANSVERSE WIND SPEED (MPH): ".VTRANS 
330 VTRANS»VTRANS*24! 

340 PRINT 

350 INPUT "ENTER THE TRANSVERSE DISPERSION (SQ MILES/D): ",DTRANS 
360 PRINT 
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370 REM 

380 PRINT "RADIATION DOSAGE AT YOUR LOCATION AS A FUNCTION OF TIME" 
390 PRINT "DAYS","REMS"."NORM","HRS" 

400 REM 

410 ALPHA«D*D/(4*DPAR) 

420 BETA—2*D*VPAR/(4*DPAR) 

430 GAMMA-VPAR*VPAR/(4*DPAR) + VTRANS*VTRANS/(4*DTRANS) 

440 TFAC=SQR(1+4*ALPHA*GAMMA) 

450 TYMMAX-(1+TFAC)/(2*GAMMA) 

460 FACMAX=((D-VPAR*TYMMAX)~2)/(4*DPAR*TYMMAX) 

470 FACMAX-FACMAX+VTRANS*VTRANS*TYMMAX/(4*DTRANS) 

480 FOR 1-1 TO 20 STEP 1 
490 TYM-TYMMAX*(1-.02*(10-1)) 

500 FACPAR-0! : FACPER-0! 

510 DI$PAR=D-VPAR*TYM 
520 DISPER-VTRANS»TYM 
530 FACPAR-DISPAR*DISPAR/(4!*DPAR*TYM) 

540 IF DTRANSO0! THEN FACPER«DISPER*DISPER/(4!*DTRANS*TYM) 

550 FACTOR-FACPAR+FACPER 
560 COEF-TYMMAX/TYM 

570 EFFREM=REMS*COEF*EXP(FACMAX-FACTOR) 

580 NORM-EFFREM/REMS 

590 TYMHRS-TYM* 24 

600 PRINT TYM,EFFREM,NORM,TYMHRS 

610 NEXT I 

620 END 


HENON1.PAS 

"Henon Mapping with Pascal," by Gordon Hughes, December, 1986, page 161, 


PROGRAM HENON1; {short version of Henon mapping program} 

CONST 

MAXREAL: REAL - 1E+10; 

VAR 

I, J,P1,P2,ORBITN,POINTS, RESPONSE:INTEGER; 

R, L, T, B, A, XOLD, YOLD, XNEW, YNEW. X0, Y0, DX0, OY0, XSCALE, YSCALE, COS A, SINA: REAL; 
GRID: BOOLEAN; {set this to FALSE to turn off the grid} 


BEGIN 

GRID:- TRUE; A:- 1.111;L:—1.2;R 
X0:-0.098;Y0:« 0.061; DX0:» 0.04 


- 1.2; B:« -1.2; T:- 1.2; {set defaults} 
DY0:« 0.03;ORBITN:- 25; POINTS:- 500; 


WHILE RESPONSE <> 2 DO {quit when RESPONSE is 2} 

BEGIN 

CLRSCR;GOTOXY(2,1); 

WRITELNCINPUT PHASE ANGLE A (IN RADIANS BETWEEN 0 AND PI 
READLN(A); , „ . 

WRITELNCINPUT STARTING POINT FOR FIRST ORBIT (X0.Y0)’); 
READLN(X0,Y0); 

WRITELNCINPUT X AND Y INCREMENTS IN THE ORBITS: DX0.DY0’ 
READLN(DX0, OY0); 

WRITELNCINPUT NUMBER OF ORBITS’); 

READLN(ORBITN); 

WRITELNCINPUT NUMBER OF POINTS PER ORBIT’); 

READLN(POINTS); 

WRITELNCINPUT LEFT AND RIGHT WINDOW VALUES’); 
READLN(L.R); 

WRITELNCINPUT BOTTOM AND TOP WINDOW VALUES’); 
READLN(B.T); 


)•); 


); 


HIRES; 

HIRESCOLOR(3); 

IF GRID THEN {draw reference grid If GRID is TRUE} 

BEGIN 

PI:- ROUND((0.0-L)*640/(R-L)); {find origin} 

P2:- ROUND((T - 0.0)*200/(T-B)); 

IF ((R-L) < R) AND ((T-B) <T ) THEN {origin off screen so} 
BEGIN PI:-630;P2:«190 END; {draw axes at margin} 

DRAW(0,P2,640,P2,1) ; 

DRAW(PI,0,PI,200,1); 
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FOR J:-0 TO 20 DO 
BEGIN 

DRAW(64*J.P2+3,64*J,P2-3,1); 

DRAW(PI+5,20*J,PI-5,20* J,1); 

ENO; 

WRITELN('XGRID: '.(R-L)/(640/64):6:5); 

WRITELN('YGRID: \ (T-B)/(200/20):6:5); 

END; 

GOTOXY(1,1); {display plot parameters} 

WRITELN(’A - •, A: 6:5 ) ; 

WRITELNC *X0- 1 ,X0:6:5,* Y0- \Y0:7:6); 

WRITELNC*DX0 - •,DX0:7:6); 

WRITELNC *DY0 - ’,DY0:7:6); 

WRITELN(*X SCALE: *,L:6:5,’ TO 1 ,R:6:5); 

WRITELNC*Y SCALE: *,B:6:5,’ TO *.T:6:5); 

WRITELNC* *); 

WRITELN(* *); 

GOTOXY(1,22); 

WRITELNC*ORBITS CAN BE ADVANCED MANUALLY BY PRESSING ANY KEY*); 

COSA:- COS(A); SINA:« SIN(A); {save time by computing these once} 

XOLD:« X0; YOLD:- Y0; {starting point for first orbit} 

XSCALE:» 640/(R-L); YSCALE:- 200/(T-B); 

FOR J:* 1 TO ORBITN DO {start of main loop. J is orbit number} 

BEGIN 

GOTOXY(1,19); 

WRITELN(*Orbit #*.j. * of \ ORBITN); 

WRITELNC’Current X0.Y0 -’,XOLD:6:5,’ \Y0LD:6:5); 

I :■ 1; 

WHILE I <« POINTS DO {use WHILE instead of FOR to allow easy abort} 

BEGIN 

IF (ABS(XOLD) < MAXREAL) AND (ABS(YOLD) < MAXREAL) THEN 
BEGIN 

XNEW:« X0LD*C0SA -(YOLD-XOLD*XOLD)*SINA; {The Henon mapping} 

YNEW:= XOLD*SINA + (YOLD-XOLD*XOLD)*COSA; 

IF (ABS(XNEW-L) < MAXINT/XSCALE) AND (ABS(T-YNEW) < MAXINT/YSCALE) THEN 
BEGIN 

PI:* ROUND((XNEW-L)♦XSCALE); {scale the new point for plotting} 

P2;» ROUND((T-YNEW)*YSCALE); 

PLOT(PI,P2,1); 

END; 

XOLD:» XNEW; 

YOLD:- YNEW; 

END; 

IF KEYPRESSED THEN I:- POINTS+1 ELSE I;- 1+ 1; 

END; {WHILE I. End of orbit plot} 

XOLD:» X0 + J*DX0; {next starting point} 

YOLD:- Y0 + J*DY0; 

END; {for J} 

GOTOXY(1,22); 

WRITELN(’SELECT ONE: (1) NEW PLOT (CARRIGE RETURNS WILL REPEAT CURRENT DATA)’); 
WRITELNC’ (2) QUIT*); 

READLN(RESPONSE); 

END; 

END. 


HEN0N2.PAS 

"Henon Mapping with Pascal," by Gordon Hughes, December, 1986, page 161. 


PROGRAM HENON2; 

{$1 GRAPH.P} 

CONST 

MAX- 1E10; {used in main loop to X and Y values in range} 
MAXORBIT- 48; {maximum size of arrays used to store orbits} 
BUFSIZE- 128; {used below to define graphics screen buffer} 
RECSIZE- 128; 

TYPE 

HENONPLOT - RECORD {these are the parameters of a plot} 

RA :REAL; {phase angle A} 

RAXIS :INTEGER; {chloce of axis for increments} 
RXOLD0 :REAL; {initial starting point XOLD0,YOLD0} 
RYOLD0 :REAL; 
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RDXY :REAL; jincrement for 

RORBITN:INTEGER; {# of orbits ii 
RPOINTS:INTEGER; j# of points p 
RL :REAL; {window values 

RR ;REAL; 

RB :REAL; 

RT :REAL; 

RX: ARRAY[1..MAXORBIT] OF REAL; 
RY: ARRAY[I--MAXORBIT] OF REAL; 
END; 


increment for starting points} 

§ of orbits in plot} 

# of points per orbit} 

window values,LEFT.RIGHT,BOTTOM,TOP} 


I 


{orbits of plot-only} 
{essential if AXIS=4{ 


VAR 


X , <J , Is, r I ,r t., irx, im, iri, ■ w ■ • v ■ ,v^,vnvi m, , w..w. . • • • 

ORB ITL, RESPONSE, RESPON .AXIS, OPTION. POI NTS: INTEGER; 

R,L,T,B,A,XOLD,YOLD,XNEW,YNEW,XOLD0,YOLD0,DXY,BETA: REAL; 

XSCALE,YSCALE,HALFW,COSA,SINA,COSB,SINB :REAL; 

GRD,MARK,MNU,MEN,TXT,CHANGE.FIRSTTIME: BOOLEAN; 

BLANKLINE: STRING[80]; CH: CHAR; 

X.Y.XL.YL : ARRAY [1..MAXORBIT] OF REAL; {for storing orbits} 

CURRENT,PREVIOUS,STORED: HENONPLOT; {for storing plot parameters} 

BUFFER: ARRAY[1..RECSIZE,1..BUFSIZE] OF BYTE; {temporay storage of screens} 

PROCEDURE INTRO; 

BEGIN 

CLRSCR; {clear screen} 

WRITELNC HENON MAPPING PROGRAM’); 

WRITELN?* BY GORDON HUGHES, MATH DEPT’); 

WRITELNO CALIFORNIA STATE UNIVERSITY’); 

WRITELNO CHICO. CA , 95926’); 

WRITELN; ... .. ,, 

WRITELN(’This program will create a Henon mapping to your specifications..j; 
WRITELN(’A Henon mapping is an iterative mapping of the plane defined by:’); 
WRITELN• 

WRITELNf * Xnew « Xold*Cos(A) - (Yold - Xo I d*Xo I d)*S i n(A) ’); 

WRITELNC* Ynew « Xold*Sin(A) + (Yold - XoId*XoId)*Cos(A) *); 

WRITELN(’ (where A is a given parameter, called the phase angle)’); 

WRITELNC’After you finish a plot you can save your plot parameters or the ac 
WRITELN(’The program also allows you to modify existing plots.’); 

WRITELN; , A « 

WRITELNC’You will be asked to input the following general types of informati 
WRITELN(* (1) : The phase angle A’); ^ ^ , iX 

(2): The starting point (Xold.Yold) for each orbit of the plot. ); 

______ i . J I ii k</ iNPA/tpnm f mm nn Ini 



I lie bull tlliy (/vnu ynv • . V . X/ ■ ~ r r ■ A»\ 

These can be computed automatically by the program from an initial point ;; 
and an increment. ’); 

The number of points to be plotted for each orbit.’); 


WRITELNC’(3): The number of points to be p 
WRITELN(’(4): The window on the plot’); 
WRITELN; 

WRITELN(’PI ease hit any key to continue’); 
REPEAT UNTIL KEYPRESSED; 

END; {procedure intro} 

PROCEDURE DISPLAYOPTIONS; 


BEGIN 


CLRSCR; 

WRITELN• 

WRITELN(’THIS IS A LIST OF THE CURRENT SETTINGS. TO CHANGE ANY OF THESE’); 


WRITELN(’ENTER THE NUMBER OF THE OPTION FOLLOWED BY A CARRIGE RETURN’); 
WRITELN; 

IF GRO THEN WRITELN(’(1) CO-ORDINATE GRID IS ON’) 

ELSE WRITELNC(1) CO-ORDINATE GRID IS OFF’); 

WRITELN; 

IF TXT THEN WRITELN(’(2) DISPLAY OF PLOT TEXT IS ON’) 

ELSE WRITELNC(2) DISPLAY OF PLOT TEXT IS OFF’); 

WRITELN; 

IF MEN THEN WRITELNC(3) MENU DISPLAY IS ON’) 

ELSE WRITELNC(3) MENU DISPLAY IS OFF’); 

WRITELN; 

IF MARK THEN WRITELN(’(4) CROSS MARK AT STARTING POINT IS ON’) 

ELSE WRITELN(’(4) CROSS MARK AT STARTING POINT IS OFF’); 

WRITELN; 

WRITELN(’(5) NUMBER OF DECIMAL PLACES FOR DISPLAY IS \DECN); 
G0T0XYO ,23); 

WRITELNC’CARRIGE RETURN TO QUIT’); 

G0T0XY(1,15); 

END; {procedure dlsplayoptions} 
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PROCEDURE CHANGEOPTIONS; 
BEGIN 


REPEAT 
OPTION:- 0; 

READLN(OPTION); 

CASE OPTION OF 

1: IF GRD THEN GRD:-FALSE ELSE GRD:- TRUE; 

2: IF TXT THEN TXT:- FALSE ELSE TXT:- TRUE; 

3: IF MEN THEN MEN:- FALSE ELSE MEN:- TRUE; 

4: IF MARK THEN MARK:-FALSE ELSE MARK:- TRUE; 

5: BEGIN 

WRITELN; 

WRITELN(* HOW MANY PLACES WOULD YOU LIKE (2-11 WITHOUT 8087,2-16 WITH)*); 
READLN(DECN); 

END; 

END; 

UNTIL OPTION = 0; 

END; {procedure changeoptIons} 


PROCEDURE SEARCH; {interactive search using cursor keys} 

BEGIN 

HIRES;HIRESC0L0R(3); 

PUTPIC(BUFFER,0,199); {restore last plot} 

PI:- ROUND((X[1]-L)*XSCALE); Q1:« ROUND((T- Y[1])*YSCALE); 
FOR K:« -6 TO 6 DO {draw Initial cross} 

BEGIN 

PLOT(P1+K,Q1, 1); 

PLOT(PI.Q1+K,1); 

END; 


GOTOXY(1,20); 

WRITELN(*USE ARROW KEYS TO POSITION CROSS AT LOWER LEFT OF SEARCH AREA AND PRESS ESC’); 
FIRSTTIME:- TRUE; {used for erase routine} 

REPEAT 

READ(KBD.CH); 

IF (CH « #27) AND KEYPRESSED THEN 
BEGIN 

IF FIRSTTIME THEN 

FOR K:« -6 TO 6 DO {erase initial cross} 


BEGIN 

PLOT(P1+K,Q1,0); 
PLOT(PI,Q1+K,0); 
END; 


READ(KBD.CH); 


CASE CH OF 



#75: X[11 

:- X 

‘1 

#77: X[1, 

:- X 

'l 

#72: Y[1 

:= Y 

! 1 

#80: Y[1' 

:= Y 

'l 

END; |CASE{ 




-0.1*DXY; {left} 

+ 0.1*DXY; {RIGHT} 
+ 0.1*DXY; {up} 
-0.UDXY; {down} 


PI:= ROUND((X[1]-L)*XSCALE); Q1:= ROUND((T- Y[1])*YSCALE); 
IF NOT FIRSTTIME THEN {erase old cross} 

FOR K:« -4 TO 4 DO 
BEGIN 

PLOT(TP1+K,TQ1,0); 

PLOT(TP1,TQ1+K,0); 

END; 


FOR K:= -4 TO 4 DO 
BEGIN 

PLOT(P1+K.Q1»1); 

PLOT (PI ,QUK,1); 

END; 

TP1: = P1;TQ1:- Q1; {save old values for erasure} 

FIRSTTIME:- FALSE; 

END; 

UNTIL (CH =#27) AND NOT KEYPRESSED; 

PI:- ROUND((X[1]-L)*XSCALE); Q1:« ROUND((T- Y[ 1])*YSCALE); 

GOTOXY(1,20); 

WRITELN(’USE ARROW KEYS TO MOVE TO UPPER RIGHT CORNER OF SEARCH AREA AND PRESS ESC 
FIRSTTIME:= TRUE; 

X[2]:- X[1];Y[2]:- Y[l]; 

REPEAT 
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READ(KBD.CH); 

IF (CH =#27) AND KEYPRESSED THEN 
BEGIN 

READ(KBD.CH); 

CASE CH OF 


#75: 

#77: 

#72: 

#80: 


-0.1*DXY; 

+ 0.UDXY; | 

. 0.1 *DXY; }. r , 
-0.1*DXY; {down} 


{left} 
RIGHT} 
up} 


P2:= ROUND((X[2]-L)*XSCALE); Q2:= ROUND((T- Y[2])*YSCALE); 
IF NOT FIRSTTIME THEN 


BEGIN 

DRAW(PI,Q1,P1,TQ2,0); {erase old box} 
DRAW(PI,TQ2,TP2,TQ2,0); 

DRAW(TP2,TQ2,TP2,Q1,0): 

DRAW(TP2,Q1,P1,Q1.0): 

END; 


DRAW(PI,Q1,P1,Q2,1); {draw new box} 

DRAW(PI,Q2,P2,Q2,1); 
DRAW(P2,Q2,P2,Q1.1); 
DRAW(P2.Q1,P1,Q1.1): 


TP2:= P2; TQ2:= Q2; {save old values for erasure of old box} 
FIRSTTIME:= FALSE; 

END; 

UNTIL (CH =#27) AND NOT KEYPRESSED; 

END; {procedure search} 


PROCEDURE DISPLAYORBITS; 


BEGIN 

WIND0W(1,3,80,25); 

FORK^ORBITN + 1 TO MAXORBIT DO BEGIN X[K]:= 0.0; Y[K]:= 0.0 END; {zero junk} 

IF ORBITN > 24 THEN WRITELN('THE FIRST 24 CURRENT ORBITS ARE’) 

ELSE WRITELN(’THE CURRENT ORBITS ARE’); 

FOR K•= 1 TO 9 DO WRITELNC * ',K,' ', X[K]:DECN:DECN-1,' *,Y[K]:DECN:DECN-1); 

FOR K:« 10 TO 12 DO WRITELN( * \K,' * . X[K]:DECN:DECN-1.' * ,Y[K] :DECN:DECN-1) ; 

IF ORBITN >12 THEN 
BEGIN 

WRITELN; v , , 

WINDOW(2*DECN+8, 4,80,20); {continue on next column* 

GOTOXY(1,1); 

WRTTFLN• 

FOR K:=’l3 TO 24 DO WRITELNC K.* \ X[K]:DECN:DECN-1. 1 *.Y[K]:DECN:DECN-1); 

END; 

WINDOW(1,1,80,25);GOTOXY(1,18); 

END; {procedure dispIayorblts} 

PROCEDURE DISPLAYDATA; 

BEGIN 

CLRSCR* 

yypjf£LN(* THE CURRENT PLOT DATA IS:’); 

WRITELN(’PHASE ANGLE A = ’, A:5:4); 

IF AXIS 04 THEN 
BEGIN 

WRITELN; 

WRITE(’AXIS SELECTED IS: ’); 

CASE AXIS OF 

1: WRITELNC(1) AXIS OF SYMMETRY’); 

- - N(*(2) X AXIS’); 

M(’(3) AXIS OF CHOICE’); 


2: WRITELN( 

3: WRITELN( 

END; 

WRITELN 1 

WRITELN('STARTING POINT X0,Y0 IS ',X[1]:DECN;DECN-1, ' ',Y[1]:DECN:DECN-1); 

WRITELN; 

WRITELNCINCREMENT DXY « DXY;DECN:DECN-1); 

WRITELN; 

WRITELNCNUMBER OF ORBITS * '.ORBITN); 

WRITELN; 
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WRITELN(’NUMBER OF POINTS PER ORBIT - \POINTS); 

WRITELN; 

WRITELNf *WINDOW VALUES ARE: 1 ); 

WRITELN(* X-AXIS: *.L:DECN:DECN-1, * TO *,R:DECN:DECN-1,• 

YAXIS: ’,B:DECN:DECN-1, 1 TO \ T:DECN:DECN-1) 

WRITELN; 

END 

ELSE 

BEGIN 

DISPLAYORBITS * 

WRITELN(’TOTAL NUMBER OF ACTIVE ORBITS- \ORBITN); 

WRITELN(’NUMBER OF POINTS PER ORBIT - ’,POINTS); 

WRITELNf'WINDOW VALUES ARE:’); 

WRITELN(’ X-AXIS: ’,L:0ECN-2:DECN-3, * TO ’,R:DECN-2:DECN-3,’ 

YAXIS: ’,B:DECN-2:DECN-3, ’ TO \T:DECN-2 

END; 

IF XOLO0 - 0.0 THEN BETA:- PI/2 {update BETA} 

ELSE BETA:- ARCTAN(YOLD0/XOLD0); 

XSCALE:- 640/(R-L); YSCALE:- 200/(T-B); {update scale factors} 

GOTOXY(1,23); 

WRITELN(’IF THERE ARE NO CHANGES PRESS ESCAPE TO START PLOT’); 

WRITE(’OTHERWISE PRESS ANY OTHER KEY TO CONTINUE’); 

REPEAT UNTIL KEYPRESSED; 

BEGIN 

READ(KBD.CH); 

IF (CH = #27) AND NOT KEYPRESSED THEN CHANGE:- FALSE ELSE CHANGE:- TRUE; 
END; 

WINDOW(1,1,80,25); GOTOXY(I.I); 

END; {procedure displaydata} 


PROCEDURE MODIFYORBITS; 


VAR 

ORB IT1 .ORB I T2 :INTEGER; 


BEGIN 

CLRSCR;DISPLAYORBITS; 
WRITELN(’PLEASE SELECT ONE 
WRITELN 
WRITELN 
WRITELN 
WRITELN 
WRITELN 
WRITELN 

READLN(RESPON); 

CASE RESPON OF 
1: BEGIN 


*): 

(1) KEEP SAME ORBITS BUT CHANGE NUMBER OF POINTS PER ORBIT’); 
'2) EXPAND ON A SUBSET OF THESE ORBITS’); 

EXPAND ABOUT A SINGLE ORBIT’); 

EXPAND INTERACTIVELY ABOUT A POINT FROM LAST PLOT’); 

ENTER NEW ORBITS’); 

CARRIGE RETURN TO START PLOT’); 


WRITELN; 

WRITELN(*INPUT THE NUMBER OF POINTS TO BE PLOTTED PER ORBIT. MAX IS 32000’); 
READLN(POINTS); 

END; 

BEGIN 
AXIS:- 4; 

ORBIT1:-1;ORBIT2:-ORBITN; {defaults} 

WRITELN(’INPUT THE STARTING ORBIT # AND FINAL ORBIT # FOR NEW PLOT’); 
READLN(ORBIT1.ORBIT2); 

WRITELN(’INPUT NUMBER OF ORBITS IN THE NEW PLOT’); 

READLN(ORBITN); 

X[1]:- X[ORBIT1]; Y[l]:= Y[ORBIT1];X[ORBITN]:- X[ORBIT2];Y[ORBITN]:= Y[ORBIT2]; 
DXY:= SQRT( SQR (X[ORBIT2] -X[ORBIT1]) + SQR(Y[ORBIT2]-Y[ORBIT1]))/(ORBITN-1); 
WRITELN(’INPUT THE NUMBER OF POINTS FOR EACH ORBIT’); 

READLN(POINTS); 

BETA:- ARCTAN(Y[1]/X[1]); 


FOR K:- 2 TO ORBITN-1 DO {generate new orbits} 
BEGIN 

X[K]:= X[K-ll+ DXY*COS(BETA); 

Y[K]:= Y[K-1]+ DXY*SIN(BETA); 

END; 

XOLD0:- X[1];YOLD0:= Y[1]; 

END; 
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3: BEGIN 

AXIS WRITELN(’PLEASE ENTER THE CO-ORDINATES OF THE POINT OF INTEREST’); 
READUN(XNEW.YNEW); v „ i/fww . 

WRITELN(’PLEASE ENTER THE INCREMENT DXY’); READLN(DXY); 

WRITELN(’PLEASE ENTER THE NUMBER OF ORBITS DESIRED ON EACH SIDE OF THE POINT'); 
WRITELN(’OF INTEREST: ORBITS TOWARD THE ORIGIN AND ORBITS AWAY FROM IT’); 
READLN(ORBIT1.ORBIT2); 

ORBITN:- ORBIT1 + ORBIT2 + 1; 

IF XNEW <> 0.0 THEN 

BETA;- ARCTAN(YNEW/XNEW) 

ELSE BETA:- 0.0; 

X[1]:- XNEW - ORBIT1*DXY*COS(BETA); 

Y[1]:= YNEW - ORBIT1*DXY*SIN(BETA); 

FOR K:= 2 TO ORBITN DO 
BEGIN 

X[K]:= X[K-1]+ DXY*COS(BETA); 

Y[KJ:= Y[K-1]+ DXY*SIN(BETA); 

XTORBITI+1]XNEW;Y[ORBIT1+1]YNEW; {to make sure this point is included} 
WRITELNf’PLEASE INPUT THE NUMBER OF POINTS PER ORBIT’); 

READLN(POINTS); 

END; 


4: BEGIN 

AXIS -- *£ arch . j now x[1].Y[1], X[2),Y[2] contain lower left and upper right of search area} 
WRITELNf’INPUT THE NUMBER OF ORBITS DESIRED’); 

IF A ORBITN B <> N l’THEN DXY:= SQRT( SQR (X[2]-X[l]) + SQR(Y[2]-Y[1]))/(0RBITN-1) 

ELSE DXY:= 0.0; {only one orbit desired} 

WRITELN(*INPUT THE NUMBER OF POINTS FOR EACH ORBIT’); 

IF A X[2^ P <> N X[1j THEN BETA:- ARCTAN(Y[2]-Y[1])/(X[2]-X[1]) 

ELSE BETA:- PI/2; , , 

FOR K:» 2 TO ORBITN DO {generate new orbits} 


BEGIN 

X[K]:- X[K-1]+ DXY*COS(BETA); 
Y[KJ:- Y[K-1]+ DXY*SIN(BETA); 
END; 

XOLD0:- X[1];YOLD0:- Y[1]; 

END; 


5:BEGIN 

AXIS** 4; 

WRITELN(’EXISTING ORBITS WILL REMAIN UNLESS CHANGED. HOW MANY ORBITS’); 
WRITELN(’WOULD YOU LIKE TO REMAIN ?’); 

READLN(0R8ITN); „ w , 

WRITELNf’PLEASE ENTER ANY NEW ORBITS IN THE FORM: ORBIT# X Y’); 
WRITELNf’WHEN FINISHED ENTER 0 ORBIT# TO TERMINATE’); 

WHILE I > 0 DO READLN(I,X[I],Y[I]); 

WRITELN(’PLEASE ENTER THE NUMBER OF POINTS PER ORBIT’); 

READLN(POINTS); 

END; {item 3} 

END; {case} 

XOLD0:- X[1];YOLD0:= Y[1]; 

CLRSCR; 

DISPLAYORBITS; 

GOTOXYfl,22);WRITELN(’PRESS ANY KEY TO CONTINUE’); 

REPEAT UNTIL KEYPRESSED; 

RESPON:- 0; 

END; {procedure modifyorbits} 


PROCEDURE OBTAINDATA; 

BEGIN 

CLRSCR * 

IF (RESPONSE <> 2) THEN {skip A and AXIS input for MENU item 2} 

BEG IN 

WRITELNf’INPUT PHASE ANGLE A (IN RADIANS BETWEEN 0.0 AND PI)’); 

WRITE(’CURRENT VALUE IS *);WRITE(A:DECN:DECN-1, ’ ’); 

READLN(A);WRITELN; 

SINA:- SIN(A); COSA:- COS(A); 

WRITELNf'INCREMENT ALONG: (1) AXIS OF SYMMETRY (2) X-AXIS’); 

( continued ) 
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WRITELN(* 

WRITE(’CURRENT VALUE IS 
READLN(AXIS);WRITELN; 
END; 


(3) AXIS OF CHOICE 
’); WRITE(AXIS, ' 


(4) NO AXIS-ORBITS 
*): 


FROM ARRAYS X AND Y’); 


CASE AXIS OF 
1: BEGIN 

BETA:- A/2; 

IF BETA < PI/4 THEN 
BEGIN 

WRITELN(’INPUT STARTING POINT X0’); 

WRITE(’CURRENT VALUE IS ’);WRITE(XOLD0:DECN:DECN-1, ’ •); 

READLN(XOLD0); WRITELN; 

YOLD0:= SIN(BETA)*XOLD0/COS(BETA); 

END ELSE 
BEGIN 

WRITELNOINPUT STARTING POINT Y0’); 

WRITE(’CURRENT VALUE IS ’);WRITE(YOLD0:DECN:DECN-1,’ ’); 

READLN(YOLD0); WRITELN; 

XOLD0:= COS(BETA)*YOLD0/SIN(BETA) 

END; {if A} 

END; {item 1} 

2: BEGIN 

BETA:- 0.0; 

WRITELN(’INPUT STARTING POINT X0’); 

WRITE(’CURRENT VALUE IS ’);WRITE(XOLD0:DECN:DECN-1, ’ ’); 

READLN(XOLD0); WRITELN; 

YOLD0:- 0.0; 

END; 

3: BEGIN 

WRITELN(*INPUT X AND Y CO-ORDINATES OF ANY POINT ON THE DESIRED AXIS'); 

WRITE(’CURRENT VALUE IS ’);WRITE(XOLD0:DECN:DECN-1,’ ’.YOLD0:DECN:DECN-1,’ 
READLN(XOLD0,YOLD0); WRITELN; 

IF XOLD0 - 0.0 THEN 
BEGIN 

BETA:- PI/2; 

WRITELN(’INPUT STARTING POINT Y0’) ; 

WRITE(’CURRENT VALUE IS ’);WRITE(YOLD0:DECN:DECN-1,’ ’); 

READLN(YOLD0)jWRITELN; 

END 

ELSE 

BEGIN 

BETA:- ARCTAN(YOLD0/XOLD0); 

WRITELN(’INPUT STARTING POINT X0’); 

WRITE(’CURRENT VALUE IS ’); WRITE(XOLD0:DECN:DECN-1.’ ’); 

^READLN(XOLD0); WRITELN; YOLD0:= XOLD0*SIN(BETA)/COS(BETA); 

END; 

4: MODIFYORBITS; 

END; {case} 


IF AXIS <> 4 THEN 
BEGIN 

WRITELNOINPUT INCREMENT DXY’); 

WRITE(’CURRENT VALUE IS ’); WRITE(DXY:DECN:DECN-1, 
READLN(DXY)jWRITELN; 

WRITELNOINPUT NUMBER OF ORBITS’); 

WRITE(’CURRENT VALUE IS ’);WRITE(ORBITN, * 
READLN(ORBITN); WRITELN; 

WRITELNOINPUT NUMBER OF POINTS FOR EACH ORBIT’); 
WRITE(’CURRENT VALUE IS ’); WRITE(POINTS, ’ 

READLN(POINTS); WRITELN; 

X' * 

X 
Y 

END; 


*): 


1 ] : = XOLD0; Yfl]:= YOLD0; 


ORBITN] 
ORBITNJ: 


[!]: 


DXY*ORBITN*COS(BETA); 
DXY*ORBITN*SIN(BETA) 


; I 


*); 




these might be needed 
of window below} 


for automatic calculation} 


WRITELNOINPUT LEFT AND RIGHT WINDOW VALUES (ENTER 0.0,0.0 FOR AUTO CALCULATION) ’); 
WRITE(’CURRENT VALUE IS ’);WRITE(L:DECN:DECN-1, ’ •,R:DECN:DECN-1, ’ ’)• 

READLN(L.R); 

IF L = R THEN { perform auto calculation of window} 

BEGIN {first find largest leg of final orbits} 

IF A8S(X[0RBITN]-X[1J) > ABS(Y[ORBITN]-Y[1]) 

THEN HALFW:- X[ORBITN]-X[1] ELSE HALFW:-Y[ORBITN]-Y[ll; 

L:= X[ll- HALFW; R:- X[11+ 1.1*HALFW; 

B:- Y[1J- HALFW; T:- Y[l]+ 1.1*HALFW; 
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END 

ELSE 

BEGIN 

WRITELN* 

WRITELN(’INPUT BOTTOM AND TOP WINDOW VALUES'): 
WRITE(’CURRENT VALUE IS ’);WRITE(B:DECN:DECN-1. 
READLN(B.T); 

XSCALE:• 640/(R-L);YSCALE:- 200/(T-B); 

END; {procedure obtaindata} 


’,T:DECN:DECN-1, 




PROCEDURE DRAWGRID; 


VAR 


ZX.ZY:INTEGER; { zx.zy is the origin of the plot} 


BEGI IF (ABS(L*XSCALE) < 30000) AND (ABS(T*YSCALE) < 30000) THEN 

ZX G - N ROUND((0.0-L)*XSCALE); {compute origin (ZX.ZY)} 

ZY:- ROUND((T - 0.0)*YSCALE) 

END 
ELSE 
BEGIN 
ZX:- 639; 

ZY:- 199 

DRAW (0.ZY,640.ZY, 1); i draw x ond Y ox ® s * 

-“ 3 . 1 ); 


DRAW(ZX,0.ZX,200, 


IF (L > 0.0) AND (B > 0.0) 
BEGIN ZX:-639;ZY:=199 END; 


THEN 


{if origin off screen} 

{set it to edge to retain grid marks} 


FOR J: —10 TO 10 DO 
BEGIN . 

DRAW(ZX+64*J.ZY+3.ZX+ 64*J,ZY-3,1); 
DRAW(ZX+5,ZY+20*J,ZX-5,ZY+20*J.1); 
END; , 

END; {procedure drawgrld} 


{draw grid marks starting at origin} 


PROCEDURE DRAWTEXT; 

BEGIN 

IF AXIS = 4 THEN 

BEGIN XOLD0:- X[l]; YOLD0;- Y[1] END; 

GOTOXY(I.I); {display plot parameters} 

WRITELN(’A = ’,A:5:4); 

WRITELN; 

WRITELN[’X0!Y0 A - - R XOLD0?DECN:DECN-1.’.',YOLD0:DECN;DECN-1); 
WRITELN; 

IF AXIS <> 4 THEN 
BEGIN 

WRITELNCINCREMENT ALONG:’); 

CASE AXIS OF ... rn o l - 

1: WRITELN(’AXIS OF SYMMETRY’); 

2: WRITELNf’X AXIS’); 

3: WRITELN(’AXIS OF CHOICE’); 


END; 

END 

ELSE 

WRITELN(’ORBITS FROM ARRAYS’); 

ip 1 (RESPON <> 2) AND (RESPONSE <> 8) THEN WRITELN(* INCREMENT DXY = ’.DXY:DECN:DECN-1); 

GOTOXY(I.U); 

IF GRD THEN 

^^WRITELNC'X SCALE: *,L:DECN:DECN-1,’ TO *,R:DECN:DECN-1); 

WRITELN(*Y SCALE: *,B:DECN:DECN-1,* TO ’,T:DECN:DECN-1); 

WRITELNC’XGRID MARK: \ ( R -L)/(640/64):DECN:DECN-1)^ 

WRITELN(*YGRID MARK: (T-B)/(200/20):DECN:DECN-1); 

END; 

WRITELN(’PRESS ANY KEY TO ADVANCE ORBITS MANUALLY’); 

END; {procedure drawtext} 


(continued) 
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PROCEDURE PLOTORBITS; 

CONST MAXREAL: REAL - 1E+30; 

VAR 

PI,P2:INTEGER; 

BEGIN 

SINB:■ SIN(BETA); COSB:« COS(BETA); 

SINA:-SIN(A);COSA:- COS(A); 

FOR J:* 1 TO ORBITN DO {generate starting points Xold0,yold0 for each orbit} 
BEGIN 

GOTOXY(1,11); 

IF TXT THEN 

WRITELN('ORBIT #’,J, * OF *,ORBITN,':'); 

IF AXIS = 4 THEN 

BEGIN XOLD0:- X[J]; YOLD0:- Y[J] END; {use arrays In no-axis option} 

IF J <- MAXORBIT THEN 

BEGIN X[J]:« XOLD0; Y[J]:- YOLD0 END; {update matrix} 

IF TXT THEN 

WRITELN(’X0,Y0 = \ XOLD0:DECN:DECN-1, • ',YOLD0:DECN:DECN-1); 

XOLD:- XOLD0; YOLD:- YOLD0; {set starting point to xold0,yold0} 

IF MARK THEN {draw a mark at the initial point XOLD0.YOLD0} 

BEGIN 

PI;- ROUND((XOLD-L)*XSCALE); P2:» ROUND((T- YOLD)*YSCALE); 

FOR K:- -2 TO 2 DO 
BEGIN 

PLOT(P1+K,P2,1); 

PL0T(P1,P2+K,1) 

END; 

IF RESPONSE- 8 THEN {for merged plots use two values of POINTS} 

IF J > PREVIOUS.RORBITN THEN POINTS:-STORED.RPOINTS; 

END; 

I; - 1; 

WHILE I <- POINTS DO 
BEGIN 

IF (ABS(XOLD) < MAX) AND (ABS(YOLD) < MAX) THEN {check for out of range} 
BEGIN 

XNEW:« XOLD*COSA -(YOLD-XOLD*XOLD)*SINA; {The Henon mapping} 

YNEW:» XOLD*SINA + (YOLD-XOLD*XOLD)*COSA; 

IF (ABS(XNEW-L) < MAXINT/XSCALE) AND (ABS(T-YNEW) < MAXINT/YSCALE) THEN 
BEGIN 

PI:- ROUND((XNEW-L)*XSCALE); {scale the new point for plotting} 

P2:- ROUND((T-YNEW)*YSCALE); 

PLOT(PI,P2,1); 

END; 

XOLD:- XNEW; 

YOLD:- YNEW; 

END; 

IF KEYPRESSED THEN I:- POINTS+1 ELSE Is- 1+ 1; 

END; {WHILE I. End of orbit plot} 

XOLD0:* XOLD0 + COSB*DXY; {increment along chosen axis} 

YOLD0:- YOLD0 + SINB*DXY; 

END; |For J. Start next orbit} 

END; {procedure plotorbits} 


PROCEDURE MENU; 

VAR 

FIL: FILE; {untyped file for storing screen images} 

FIL2: TEXT; {text file for storing parameters} 

PICNAME,FNAME: STRING[14]; 

MNU: BOOLEAN; 

BEGIN 

MNU:- TRUE; 

GETPIC(BUFFER,0,0,639,199); {store screen in buffer} 

WITH CURRENT DO {save plot parameters in record CURRENT} 
BEGIN 

RA:- A;RAXIS:- AXIS;RXOLD0:= X[1];RYOLD0:= Y[1]; 

RDXY:* DXY;RORBITN:* ORBITN;RPOINTS:= POINTS;RL:=L; 

RR:= R;RB:= B; RT:- T; 
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FOR K:- 1 TO MAXORBIT DO 
BEGIN 

RX[K]X[K]; RY[K]:= 
END; 

END; 


Y[K]; 


WHILE MNU DO 
BEGIN 

RESPONSE:= 0; 

GOTOXY(1,19); 

FOR I:- 1 TO 6 DO WRITELN(BLANKLINE); 

GOTOXYfl.19); 

WRITELNf’SELECT ONE: (FI) NEW PLOT (CARRIGE RETURNS 
WRITELNf’(F2) REVISE ORBITS OF CURRENT PLOT 
WRITELNf’(F4) SAVE PARAMETERS OF CURRENT PLOT 
WRITELNf’(F6) RETRIEVE STORED PARAMETERS 
WRITELNf’(F8) MERGE CURRENT PLOT WITH STORED PLOT 
REPEAT UNTIL KEYPRESSED; {detect whether any of 


WILL REPEAT CURRENT VALUES)'); 

(F3) RESTORE PREVIOUS PLOT’); 

(F5) SAVE SCREEN OF CURRENT PLOT’); 
(F7) RETRIEVE STORED SCREEN ’); 
(F9) CHANGE OPTIONS (F10) QUIT’); 
the 10 function keys are pressed} 


READ(KBD.CH); 

IF (CH - #27) AND KEYPRESSED THEN 


READ(KBD.CH); 


{function keys generate two characters 


\ 


CASE CH OF 

#59: BEGIN {FI pressed- New Plot} 

RESPONSE:- 1; 

MNU:- FALSE; {do not repeot menu} 

PREVIOUS:- CURRENT; {save current parameters} 
XOLD0:-X[l];YOLD0:= Y[l]; 

END; 

#60: BEGIN 

RESPONSE:- 2; }F2 pressed-Modify orbits} 

MNU:- FALSE; {do not repeat menu} 

PREVIOUS:- CURRENT; 

AXIS:- 4; 

END; 

#61: BEGIN {F3 pressed-restore previous plot} 


DO 

RA;AXIS:- RAXIS;XOLD0:=RXOLD0;YOLD0:= RYOLD0; 

RDXY; ORBITN:- RORBITN;POINTS:- RPOINTS; 

RL;R:-RR;B:-RB;T:-RT; 

DO 

RX[K]; Y[K]:- RY[K]; 


. decimal places} 
to 11 without 8087 support} 


RESPONSE:- 3; 

MNU:- FALSE; 

WITH PREVIOUS 
BEGIN 
A:- 
DXY: 

L:- ... .... 

FOR K:- 1 TO MAXORBIT 
BEGIN 
X[K]: 

END; 

END; 

PREVIOUS:- CURRENT; 

END; 

#62: BEGIN x ....... 

RESPONSE:- 4; {F4 pressed-save plot parameters in text fliej 

MNU:- TRUE; 

TEMP:- DECN; {to restore current 

DECN: = 16; {change this tv .. -....v-. wv. 

GOTOXY(1.23);WRITE(BLANKLINE);GOTOXY(1,23); 

WRITEf’INPUT NAME OF FILE TO CONTAIN PARAMETERS 

WRITELN(FIL2,A^DECN:DECN-1)^WRITELN(FIL2,AXI$);WRITELN(FIL2,X[1]:DECN:DECN-1); 
WRITELNfFIL2,Y[11:DECN:DECN-1);WRITELN(FIL2,DXY:DECN:DECN-1);WRITELN(FIL2.ORBITN); 
WRITELN(FIL2,POINTS);WRITELN(FIL2,L:DECN:DECN-1);WRITELN(FIL2,R:DECN:DECN-1); 

WRITELN(FIL2.B:DECN:DECN-1);WRITELN(FIL2.T:DECN:DECN-1); 

FOR K:- 1 TO MAXORBIT DO WRITELN(FIL2,X[K]:DECN:DECN-1,’ ’,Y[K]:DECN:DECN-1); 

{use formatted write for compotobiIity without 8087} 

{note single space between X[K] & Y[K]-seems necessary} 

{for Pascal to read these properly} 

CLOSE(FIL2); 

DECN:- TEMP; 

END; 

#63: BEGIN 

RESPONSE:- 5; {F5 pressed-save graphics plot in untyped file} 

MNU:- TRUE; 

GOTOXYfl,23); WRITE(BLANKLINE);GOTOXYfl,23); 

WRITEf’INPUT NAME OF FILE TO CONTAIN PLOT ’);READ(PICNAME); 

ASSIGNfFIL.PICNAME); REWRITE(FIL); 


’);READ(FNAME); 


(continued) 
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BLOCKWRITE(FIL.BUFFER,127); CLOSE(FIL); 

GOTOXY(1,18) ; WRITELN(‘COPY COMPLETE.PLEASE CHOOSE FROM MENU'); 

END; 

#64: BEGIN 

RESPONSE:- 6; {F6 pressed-retrleve stored parameters! 

MNU:- FALSE; 

PREVIOUS:- CURRENT; {save old parameters! 

GOTOXY(1,23);WRITE(BLANKLINE);GOTOXY(1,23); 

WRITECINPUT NAME OF FILE WHERE PARAMETERS ARE STORED *); 

READLN(FNAME); 

ASSIGN(FIL2,FNAME);RESET(FIL2); 

READLN(FIL2,A); READLN(FIL2,AXIS); READLN(FIL2,XOLD0); 
READLN(FIL2.YOLD0);READLN(FIL2,DXY);READLN(FIL2,ORBITN); 

READLN(FIL2,POINTS);READLN(FIL2,L);READLN(FIL2.R); 

READLN(FIL2,B);READLN(FIL2,T); 

FOR K:- 1 TO MAXORBIT DO READLN(FIL2,X[Kl,Y[Kl); 

CLOSE(FIL2); 

IF ORBITN <- MAXORBIT THEN AXIS:- 4 ; (use existing arrays} 

WITH CURRENT DO {store plot parameters in record CURRENT} 

BEGIN 

RA:- A;RAXIS:- AXIS;RXOLD0:- X[1];RYOLD0:- Y[1]; 

RDXY:= DXY;RORBITN:= ORBITN;RPOINTS:- POINTS;RL:-L; 

RR:- R;RB:- B; RT:- T; 

FOR K:« 1 TO ORBITN DO 
BEGIN 

RX[K]:» X[K];RY[K]:= Y[K]; 

END; 

END; 

END; 

#65: BEGIN |F7 pressed-retrieve graphics screen} 

RESPONSE:- 7; 

GOTOXY(1.23); WRITE(BLANKLINE);GOTOXY(1,23); 

WRITECINPUT NAME OF FILE WHERE SCREEN IS STORED *); 

READLN(PICNAME); 

ASSIGN(FIL.PICNAME);RESET(FIL);BLOCKREAD(FIL,BUFFER,127); 

HIRES;HIRESC0L0R(3); 

PUTPIC(BUFFER,0,199); CLOSE(FIL); 

GOTOXYC ,23); 

WRITELN(’TO MODIFY THIS PLOT,ENTER THE PARAMETERS USING ITEM(l) OF THE MENU’); 
WRITE(’PRESS ANY KEY TO CONTINUE’); 

REPEAT UNTIL KEYPRESSED; 

END; 

#66: BEGIN 

RESPONSE:- 8; {F8 pressed-merge orbits of current plot with stored plot} 

MNU:-FALSE; 

PREVIOUS:- CURRENT; 

GOTOXY(1,23);WRITE(BLANKLINE);GOTOXY(1,23) ; 

WRITECINPUT NAME OF FILE WHERE PARAMETERS ARE STORED ’); 

READLN(FNAME); 

ASSIGN(FIL2,FNAME);RESET(FIL2); 

WITH STORED DO {put parameters in record STORED} 

BEGIN 

READLN(FIL2,RA); READLN(FIL2,RAXIS); READLN(FIL2,RXOLD0); 
READLN(FIL2.RYOLD0);READLN(FIL2,RDXY);READLN(FIL2,RORBITN); 
READLN(FIL2,RPOINTS);READLN(FIL2,RL);READLN(FIL2,RR); 
READLN(FIL2.R8);READLN(FIL2,RT); 

FOR K:- 1 TO MAXORBIT DO READLN(FIL2,RX[K],RY[K]); 

CLOSE(FIL2); 

FOR K:- 1 TO (MAXORBIT-ORBITN) DO {merge or rays-incIuding{ 

BEGIN {any zero elements} 

X[ORBITN+K]:= RX[K];YfORBITN +K]: = RY[K]; 

END; 

IF ORBITN+RORBITN <MAXORBIT THEN 
0R8ITN:=0RBITN+R0RBITN ELSE ORBITN:- MAXORBIT; 

END; {with stored} 

AXIS:- 4; 


END; 

#67: BEGIN {F9 pressed-change options such as TEXT,GRID,MARK} 
RESPONSE:- 9; 

DISPLAYOPTIONS; 

CHANGEOPTIONS 
END; 
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#68: BEGIN |F10 pressed-quit} 

RESPONSE:- 10: 

MNU:-FALSE: 

END; 

END; {Case} 

END; {while} 

END: {procedure menu} 

BEGIN {main program} 

GRD:= TRUE: MARK:- TRUE;TXT:= TRUE;MEN:= TRUE; {defaults} 

L:—1.2;R:- 1.2; B:- -1.2; T:- 1.2; 

0RBITN:=25; POINTS:- 500;DECN:= 5; 

BLANKLINE** * 

FOR K: = 1 TO 40 DO BEGIN X[K]:» 0.0; V[K]:- 0.0;XL[K]:- 0.0;YL[K]:= 0.0 END; 
A:- 1.111; RESPONSE:- 0; 

AXIS:- 1;XOLD0:-0.098;YOLD0:-0.061; DXY:« 0.05; 

INTRO; 

REPEAT 

DISPLAYDATA; 

IF CHANGE THEN 
OBTAINDATA; 

HIRES;HIRESC0L0R(3); 

IF GRD THEN 
DRAWGRID; 

IF TXT THEN 
DRAWTEXT; 

PLOTORBITS; 

IF MEN THEN 
MENU 
ELSE 
BEGIN 

GOTOXY(1,24);WRITELN(’PRESS ANY KEY FOR MENU*); 

REPEAT UNTIL KEYPRESSED; 

MENU 

END; 

UNTIL RESPONSE - 10; 

END. 


A111P.01 

"Henon Mapping with Pascal," by Gordon Hughes, December, 1986, page 161. 


1.111000000000000 

4 

0.446659263865825 

0.124296194123945 

0.019311392587131 

38 

700 

- 1.200000000000000 
1.200000000000000 
- 1.200000000000000 
1.200000000000000 

0.446659263865825 0.124296194123945 
0.465970656452956 0.124296194123945 
0.485282049040086 0.124296194123945 
0.504593441627217 0.124296194123945 
0.523904834214348 0.124296194123945 
0.098000000000000 0•060828436679565 
0.140481843119658 0.087196845906456 
0.182963686239315 0.113565255133347 
0.225445529358973 0.139933664360238 
0.2679273724786310.166302073587129 
0.310409215598289 0.192670482814020 
0.352891058717947 0.219038892040911 
0.395372901837604 0.245407301267802 
0.437854744957262 0.271775710494692 
0.480336588076920 0.298144119721583 
0.522818431196578 0.324512528948474 


0.565300274316235 0.350880938175365 
0.607782117435893 0.377249347402256 
0.650263960555551 0.403617756629147 
0.692745803675209 0.429986165856038 
0.735227646794866 0.456354575082929 
0.777709489914524 0.482722984309820 
0.820191333034182 0.509091393536711 
0.862673176153840 0.535459802763602 
0.905155019273497 0.561828211990493 
0.947636862393155 0.588196621217384 
0.990118705512813 0.614565030444275 
1.032600548632470 0.640933439671166 
1.075082391752130 0.667301848898057 
1.117564234871790 0.693670258124948 
1.160046077991440 0.720038667351839 
1.202527921111100 0.746407076578730 
1.245009764230760 0.772775485805621 
1.287491607350420 0.799143895032512 
1.329973450470080 0.825512304259403 
1.372455293589730 0.851880713486294 
1.414937136709390 0.878249122713185 
1.457418979829050 0.904617531940076 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
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0.000000000000000 0.000000000000000 

0.000000000000000 0.000000000000000 

0.000000000000000 0.000000000000000 


0.000000000000000 0.000000000000000 

0.000000000000000 0.000000000000000 


A111P.02 

"Henon Mapping with Pascal," by Gordon Hughes, December, 1986, page 161. 


1.111000000000000 

4 

0.842551668000973 

0.370414833841628 

0.005259200244240 

32 

10000 

0.737809052148432 

0.948930660284989 

0.265979373814980 

0.477100981951537 

0.842551668000973 

0.847640384180403 

0.852729100359833 

0.857817816539264 

0.862906532718694 

0.867995248898124 

0.871521692106390 

0.878157400275453 

0.884793108444515 

0.891428816613578 


0.370414833841628 

0.371743048754289 

0.373071263666950 

0.374399478579611 

0.375727693492272 

0.377055908404933 

0.381018729174539 

0.383919780423921 

0.386820831673304 

0.389721882922686 


0.898064524782640 

0.904700232951702 

0.911335941120765 

0.917971649289827 

0.924607357458890 

0.809374555504569 

0.808904952177491 

0.808435348850413 

0.807965745523335 

0.807496142196257 

0.807026538869180 

0.806556935542102 

0.806087332215024 

0.805617728887946 

0.805148125560868 

0.804678522233790 

0.804208918906712 

0.803739315579634 

0.803269712252556 

0.802800108925478 


0.392622934172069 

0.395523985421452 

0.398425036670834 

0.401326087920217 

0.404227139169599 

0.419381160183259 

0.423997168418397 

0.428613176653534 

0.433229184888672 

0.437845193123810 

0.442461201358948 

0.447077209594086 

0.451693217829224 

0.456309226064362 

0.460925234299499 

0.465541242534637 

0.470157250769775 

0.474773259004913 

0.479389267240051 

0.484005275475189 


A15732P.01 

"Henon Mapping with Pascal," by Gordon Hughes, December, 1986, page 161. 


1.573200000000000 

3 

0.020000000000000 

0.050000000000000 

0.050000000000000 

70 

400 

-3.000000000000000 

3.000000000000000 

-3.000000000000000 

3.000000000000000 

0.020000000000000 0.050000000000000 
0.038569533817705 0.096423834544263 
0.057139067635410 0.142847669088526 
0.075708601453116 0.189271503632789 
0.094278135270821 0.235695338177052 
0.112847669088526 0.282119172721315 
0.131417202906231 0.328543007265578 
0.149986736723936 0.374966841809841 
0.168556270541642 0.421390676354104 
0.187125804359347 0.467814510898367 
0.205695338177052 0.514238345442630 
0.224264871994757 0.560662179986892 
0.242834405812462 0.607086014531155 
0.261403939630167 0.653509849075418 
0.279973473447873 0.699933683619681 
0.298543007265578 0.746357518163944 
0.317112541083283 0.792781352708207 
0.335682074900988 0.839205187252470 
0.354251608718693 0.885629021796733 


0.372821142536399 0.932052856340996 
0.391390676354104 0.978476690885259 
0.409960210171809 1.024900525429520 
0.428529743989514 1.071324359973780 
0.447099277807220 1.117748194518050 
0.465668811624925 1.164172029062310 
0.484238345442630 1.210595863606570 
0.502807879260335 1.257019698150840 
0.521377413078040 1.303443532695100 
0.539946946895746 1.349867367239360 
0.558516480713451 1.396291201783620 
0.577086014531156 1.442715036327890 
0.595655548348861 1.489138870872150 
0.614225082166566 1.535562705416410 
0.632794615984272 1.581986539960680 
0.651364149801977 1.628410374504940 
0.669933683619682 1.674834209049200 
0.688503217437387 1.721258043593470 
0.707072751255092 1.767681878137730 
0.725642285072798 1.814105712681990 
0.744211818890503 1.860529547226250 
0.762781352708208 1.906953381770520 
0.781350886525913 1.953377216314780 
0.799920420343618 1.999801050859040 
0.818489954161324 2.046224885403310 
0.837059487979029 2.092648719947570 
0.855629021796734 2.139072554491830 
0.874198555614439 2.185496389036090 
0.892768089432144 2.231920223580360 
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A0264P.01 

"Henon Mapping with Pascal," by Gordon Hughes, December, 1986, page 161. 


0.264000000000000 

3 

0.020000000000000 

0.040000000000000 

0.030000000000000 

25 

300 

- 1.200000000000000 
1.200000000000000 
- 1.200000000000000 
1.200000000000000 

0.020000000000000 0.040000000000000 
0.033416407865000 0.066832815730000 
0.046832815730000 0.093665631460000 
0.060249223595000 0.120498447190000 
0.073665631460000 0.147331262920000 
0.087082039324000 0.174164078650000 
0.100498447190000 0.200996894380000 
0.113914855050000 0.227829710110000 
0.127331262920000 0.254662525840000 
0.140747670780000 0.281495341570000 
0.154164078650000 0.308328157300000 
0.167580486510000 0.335160973030000 
0.180996894380000 0.361993788760000 
0.194413302240000 0.388826604490000 
0.207829710110000 0.415659420220000 
0.221246117970000 0.442492235950000 
0.234662525840000 0.469325051680000 
0.248078933700000 0.496157867410000 
0.261495341570000 0.522990683140000 


0.274911749430000 0.549823498870000 
0.288328157290000 0.576656314600000 
0.301744565160000 0.603489130330000 
0.315160973020000 0.630321946060000 
0.328577380890000 0.657154761790000 
0.341993788750000 0.683987577520000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 
0.000000000000000 0.000000000000000 


A2012P.01 

"Henon Mapping with Pascal," by Gordon Hughes, December, 1986, page 161. 


2.012000000000000 

1 

0.063365133757000 

0.100000000000000 

0.050000000000000 

25 

400 

-1.200000000000000 
1.200000000000000 
-1.200000000000000 
1.200000000000000 

0.063365133757000 0.100000000000000 
0.090127322998000 0.142234881640000 
0.116889512240000 0.184469763280000 
0.143651701480000 0.226704644910000 
0.170413890720000 0.268939526550000 
0.197176079970000 0.311174408190000 
0.223938269210000 0.353409289830000 
0.250700458450000 0.395644171460000 
0.277462647690000 0.437879053100000 
0.304224836930000 0.480113934740000 
0.330987026170000 0.522348816380000 
0.357749215420000 0.564583698010000 
0.384511404660000 0.606818579650000 
0.411273593900000 0.649053461290000 
0.438035783140000 0.691288342930000 
0.464797972380000 0.733523224560000 
0.491560161630000 0.775758106200000 
0.518322350870000 0.817992987840000 
0.545084540110000 0.860227869480000 


0.571846729350000 
0.598608918590000 
0.625371107830000 
0.652133297070000 
0.678895486320000 
0.705657675560000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 


0.902462751110000 
0.944697632750000 
0.986932514390000 
1.029167396000000 
1.071402277700000 
1.113637159300000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 
0.000000000000000 


(WHtirtufd) 
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A20075P.01 

"Henon Mapping with Pascal," by Gordon Hughes, December, 1986, page 161. 


2.075000000000000 

3 

0.020000000000000 

0.030000000000000 

0.030000000000000 

100 

100 

-3.000000000000000 

3.000000000000000 

-3.000000000000000 

3.000000000000000 

0.020000000000000 

0.036641005886757 

0.053282011773514 

0.069923017660271 

0.086564023547027 

0.103205029433784 

0.119846035320541 

0.136487041207298 

0.153128047094055 

0.169769052980812 

0.186410058867569 

0.203051064754326 

0.219692070641083 

0.236333076527839 

0.252974082414596 

0.269615088301353 

0.286256094188110 

0.302897100074867 

0.319538105961624 


0.030000000000000 

0.054961508830135 

0.079923017660271 

0.104884526490406 

0.129846035320541 

0.154807544150677 

0.179769052980812 

0.204730561810947 

0.229692070641083 

0.254653579471218 

0.279615088301353 

0.304576597131488 

0.329538105961624 

0.354499614791759 

0.379461123621894 

0.404422632452030 

0.429384141282165 

0.454345650112300 

0.479307158942436 


0.336179111848381 

0.352820117735137 

0.369461123621894 

0.386102129508651 

0.402743135395408 

0.419384141282165 

0.436025147168922 

0.452666153055679 

0.469307158942436 

0.485948164829193 

0.502589170715949 

0.519230176602706 

0.535871182489463 

0.552512188376220 

0.569153194262977 

0.585794200149734 

0.602435206036491 

0.619076211923247 

0.635717217810004 

0.652358223696761 

0.668999229583518 

0.685640235470275 

0.702281241357032 

0.718922247243789 

0.735563253130546 

0.752204259017302 

0.768845264904059 

0.785486270790816 

0.802127276677573 


0.504268667772571 
0.529230176602706 
0.554191685432841 
0.579153194262977 
0.604114703093112 
0.629076211923247 
0.654037720753383 
0.678999229583518 
0.703960738413653 
0.728922247243788 
0.753883756073924 
0.778845264904059 
0.803806773734194 
0.828768282564329 
0.853729791394465 
0.878691300224600 
0.903652809054735 
0.928614317884870 
0.953575826715006 
0.978537335545141 
1.003498844375280 
1.028460353205410 
1.053421862035550 
1.078383370865680 
1.103344879695820 
1.128306388525950 
1.153267897356090 
1.178229406186220 
1.203190915016360 


HENON.DOC 

"Henon Mapping with Pascal," by Gordon Hughes, December, 1986, page 161. 


) 


Program Documentation 


The program for generating these Henon mappings, HEN0N2.PAS, is written in 
Turbo Pascal for an IBM PC. It uses the graphics commands contained in 

Turbo Pascal. The Include file called GRAPH.P is a Turbo-supplied file with 
graphics subroutines. The only place you need this is for the graphics screen 
save. This program uses high-resolution monochrome graphics (640 by 200). It 
would be easy to alter this for low-resolution color graphics so the orbits 
could be differentiated by color. If you have an 8087 coprocessor with the 
Turbo-87 compiler, this program will run about 30 percent faster, and the 
precision will extend from 11 places to 16 places. This can be of real value 
for high magnification. This is explained more fully in the text. 

To use this program: 

HEN0N2 will ask for plotting parameters as described below. In each case, you 
can obtain the default by responding with a carriage return. After you run 
the program once, a carriage return will give you the last value used. Note 
that Pascal requires real numbers between -1 and 1 to be input with a leading 
zero. Thus, the number .35 must be input as 0.35. 

NOTE THAT COMMAS ARE NEITHER NECESSARY NOR ACCEPTED BETWEEN MULTIPLE INPUTS. 
The Parameters of a Plot: 

1. The angle A in radians (between 0.0 and pi). 

2. The axis along which the increments are to take place. The options are: 
Axis of Symmetry (each plot has an axis of symmetry which makes an angle of 
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A/2 with the X axis), X Axis. Axis of Choice (choose any starting point and 
the program will compute the axis), and No Axis (starting values will be 
obtained from arrays). The default is the Axis of Symmetry. 

3. A starting point for the first orbit. The default is (0.098 0.061). If 

the selected axis is Axis of Symmetry, you only need one coordinate. The _ 

program computes the other value. For the sake of convenience, when the Axis 
of Symmetry lies between 0 and pi/4, the program assumes that the starting 
point entered is the X coordinate; then the program computes the Y value. For 

on axis between pi/4 and pi/2, the program asks for the Y value. 

4 The increment for the initial points. This increment is measured along 
the selected axis. If No Axis is selected, this has no bearing. The 

default is 0.05. 

5. The window of the plot in the horizontal (X) direction. The default is - 

1.2 1.2. The program will compute a nice window size automatically if 

the values entered are 0.0 0.0. This is especially convenient for 

magnifications where the window may be difficult to choose. 

6. The window of the plot in the vertical (Y) direction. The default is - 

1.2 1 . 2 . 

7. The number of orbits to be plotted. The default is 25. 

8. The number of points in each orbit. The default is 500. 

NOTE: The orbits of any plot con be advanced monually by pressing any key 
while the plot Is in progress. This allows you to skip over uninteresting 
areas. 


At the end of each plot a menu appears with 10 items: 


(FI) NEW PLOT (CARRIGE RETURNS WILL REPEAT CURRENT VALUES) 

(F2) SELECTED ORBITS OF CURRENT PLOT (F3) RESTORE PREVIOUS PLOT 

(F4) SAVE PARAMETERS OF CURRENT PLOT (F5) SAVE SCREEN OF CURRENT PLOT 

' RETRIEVE STORED PARAMETERS (F7) RETRIEVE STORED SCREEN 

MERGE CURRENT PLOT WITH STORED PLOT (F9) CHANGE OPTIONS (F10) QUIT 

Item F2 has a number of subitems which are designed to facilitate exploration 
of a plot. One of these is on interactive search where you indicate the 
window of the search area with the cursor keys. 

In many cases it is better to save the parameters of a plot with F4 than it is 
to save the actual screen with F5. (Of course both can be saved since the 
menu reappears after a save.) The parameters ore saved in a text format which 
you con later examine and alter if you wish. These parameter files contain 
only about IK bytes while the graphics screens take about 16K bytes. The 
parameter files contain all the information necessary to recreate a plot. In 
addition they contain a listing of the actual orbits (up to the maximum you 
established with MAXORBIT, currently set at 48). In most cases this is 
redundont information, but it con be quite useful because you can then 
manipulate these arrays to eliminate certain unwonted orbits or add new ones. 
One of the most powerful options along these lines is the MERGE option 8. 

This allows you to combine two distinct parameter plots. It does not matter 
if they have different scales or even different A values. The merge simply 
merges the two arrays and uses the paramters from the current plot. 

The menu item Options (F9) allows you to turn on and off o ™mber of j** ms 
such os the GRID lines, the TEXT on the screen, the MARKS which show the 
starting values. It also allows you to adjust the number of decimal plo 
displayed on the screen. This is necessary for extended magnification. 


aces 


fed 


The Plots 

The plots in photos 1 through 3 in the orticle were obtained with an A-dek 
DXY-100 flat-bed plotter. (Similar to Roland DXY 100). The X ond 
coordinates of the points were sent to a file, ond then a seporote progran 
these to the plotter. Because the plots ore done one point at o t -e c . e 
points are spread out Into cycles, the plots con take up to 4 hours. o speed 
things up, I first sorted the points *- v + K *" v “ 

This allowed me to generate a plot In 


in X and then Y values 
about 20 minutes. 


with DBase III. 


( continued) 
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CELL.BAS 

"Abstract Mathematical Art," by Kenneth E. Perry, December 1986, page 181. 


10 REM One-dimensional cellular automata 
20 REM by Kenneth E. Perry 

30 REM - 

40 REM Screen setup 
50 KEY OFF 

60 SCREEN 1,0 :REM Medium resolution (320 x 200) 

70 COLOR 0,0 :REM Use color palette 0. 

80 REM - 


90 REM Initialize variables 

100 DEFINT A-Z :REM All variables are Integers. 

:REM Number of points in horizontally. 
:REM Number of points vertically. 

:REM SF-1 for denser graph. 

:REM Offset to leave one line blank. 


110 HRES-320 
120 VRES-200 
130 SF-2 
140 BY-10 
150 GN-INT(VRES/SF)-BY 
160 MC*INT(HRES/SF) 


:REM Max no. of cells. 

170 IF MC>255 THEN MC«255 :REM Prevent string overflow. 
180 MI“40 :REM Characters/line in graphics mode. 

190 BG=0 :REM Color of background. 

200 NU$«"" :REM No spaces Inside quotes 

210 DIM CL(3), A(MC-1), B(MC-I), RU(9), K$(-INT(-MC/MI)) 

220 REM Initialize color mapping 

230 FOR J=0 TO 3: READ CL(J): NEXT J 

240 DATA 0,2.3,1 

250 REM - 


260 REM Initialize the rule 

270 R$*"0000000000" :REM Ten zeroes 

280 CLS 

290 PRINT "Current rule is shown below. The rule" 

300 PRINT "must contain exactly 10 digits, using" 

310 PRINT "only 0, 1, 2. and 3." 

320 PRINT "Move the cursor across the rule, make" 

330 PRINT "changes as desired, and press <cr>." 

340 PRINT: PRINT R$ 

350 LOCATE 7,1 
360 LINE INPUT RT$ 

370 IF RT$*NU$ THEN END 
380 IF LEN(RT$)<>10 THEN 280 
390 0K«(1-1) 

400 FOR J=1 TO 10 :REM Make sure the rule is valid. 

410 RU(J-1)=VAL(MID$(RT$,J,1)) 

420 OK=(OK AND RU(J-1)>*0 AND RU(J-1)<=3) 

430 NEXT J 

440 IF NOT OK THEN 280 ELSE R$=RT$ 

450 REM - 


460 REM Get the number of cel Is in each generation 

470 PRINT USING "How many cells/line (### to ###)";MI,MC; 

480 INPUT NC 

490 IF NC<MI OR NC>MC THEN 470 

500 NL=INT((NC-1)/MI)+1 :REM Lines needed to show 1st gen. 

510 REM--- 

520 REM Get the initial state of the cellular automaton 
530 PRINT 

540 INPUT "Initial*predefined or random (P/R)";PR$ 

550 IF PR$oNU$ AND INSTR( 1, "Rr " ,PR$)>0 THEN GOSUB 
900 ELSE GOSUB 970 

560 A(0)=0: A(NC-1)=0 :REM Force boundaries to zero. 

570 REM - 

580 REM Start the cellular automaton running 
590 CLS 

600 PRINT "Rule ";R$ :REM Display rule 

610 FOR J=0 TO 3 

620 LOCATE 1,20+J*4 

630 PRINT USING "#=";J 

640 NX=168+J*32 

650 LINE (NX,0)-STEP(7,7),CL(J),BF 

660 NEXT J 

670 FOR Y-0 TO GN-1 

680 FOR X«0 TO NC-1 

690 IF X=0 OR X=NC-1 THEN V*3 ELSE V=CL(A(X)) 




496 BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 
















December 


700 PSET (X*SF,Y*SF+BY),V :REM Display the point. 

710 NEXT X 

720 REM - 

730 REM Compute new state of automaton 

740 FOR X-1 TO NC-2 :REM Don’t change boundary cells. 

750 Z«A(X-1 )+A(X)+A(X+1) 

760 B(X)«RU(Z) 

770 NEXT X 

780 REM Copy new values to A() from B() 

790 FOR X«1 TO NC-2: A(X)»B(X): NEXT X 

800 IF INKEY$oNU$ THEN Y-GN-1 :REM Exit if key pressed. 
810 NEXT Y 

820 WHILE INKEY$oNU$: WEND :REM Clear keyboard buffer. 
830 LOCATE 1.17: PRINT "Continue or quit (C/Q)? M ; 

840 CQ$=INKEY$ 

850 IF CQ$=NU$ THEN 840 

860 WH-INT((INSTR(1,"CcQq",CQ$)+1)/2)+1 :REM wh = 1.2.3. 
870 ON WH GOTO 840. 590. 280 

880 REM - 

890 REM Random initialization of automaton. 

900 RANDOMIZE 
910 FOR J-0 TO NC-1 

920 A(J)-INT(RND*4) :REM Random values from 0 to 3 
930 NEXT J 
940 RETURN 

950 REM - 

960 REM Initialize array A() with a preset pattern 
970 FOR J-1 TO NL 

980 IF NC>-J*MI THEN LL-MI ELSE LL«NC-(J-1)*MI 
990 K$(J)-STRING$(LL,".") 

1000 CLS 

1010 PRINT "Rule is: R$ 

1020 PRINT USING "Cells in range ### to ###:"; 
(J-1)*MI+1, (J-1)*MI+LL 

1030 PRINT "Move cursor across the field and make" 

1040 PRINT "changes as desired. Then press <cr>." 

1050 PRINT K$(J) 

1060 LOCATE 5.1 
1070 LINE INPUT K$(J) 

1080 NEXT J 

1090 K$-K$(1)+K$(2)+K$(3)+K$(4) 

1100 REM Convert string to array values. 

1110 FOR J-1 TO NC 
1120 KK$«MID$(K$,J,1) 

1130 IF INSTR(l."0123",KK$)-0 THEN A(J-1)-BG ELSE 
A(J-1)- VAL(KK$) 

1140 NEXT J 
1150 RETURN 


CELLULAR.PAS 

"Abstract Mathematical Art," by Kenneth E. Perry, December 1986, page 181. 


program cel IuIar; 

{one dimensional cellular automata } 

{ PROCEDURES 

1 procedure DispIayStatusLine; 

2 procedure DispIayGenerations; 

3 procedure ReadRuIeFromFiIe; (not used in this program) 

4 procedure GetRandomRuIe; 

5 procedure ChangeRule; (from keyboard) 

6 procedure Initia IizeAinitToBackground; 

7 procedure InitializeAinitRandom; 

8 procedure MoveAinitToAf1eId; 

9 procedure In 11ia IizeAin1tFromKeyboard; 

10 procedure SetBackground; 

11 procedure StartFinish; 

12 procedure Field80X47; 

13 procedure Field160X95; 

14 procedure FieId320X190; 

15 procedure ReadRuIeAndAinitFromFiIe; 

(not used in this program) 


(continued) 
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var 

FilVar: text; 

Line: string[20]; 

C: s t rIng[1]; 


Ainit: 

array[0. 

.4000] of byte; 

{4001 cells wide. 

Allows for } 

Afield: 

array[0. 

.4000] of byte; 

expansion of COMPUTE FIELD 

Bfield: 

array[0. 

.4000] of byte; 

Rule: 

array[0..12] of byte; 

I.J.M.N.H 

P,V,X,Nix 

: integer; 

Ch: 

char; 

Delta: 

i nteger; 

pixel spacing 1, or 2 

Dwidth: 

Integer; 

width of display field 

Cwidth: 

Integer; 

i width of compute field 

Cstart: 

Integer; 

{ COMPUTE FIELD, start wi 

Cfinish: 

integer; 

| width of 160 } 

Dstart: 

Dfinish: 

integer; 

1nteger; 

{ display field } 

Vstart: 

Vf inish: 

integer; 
integer; 

{ vertical display } 

Hstart: 

Hfinish: 

Integer; 
integer; 

{ horizontal display } 


const j typed constants } 

j these are essentially initialized variables } 


Widen: 

Integer 

- 0; 

Bgnd: 

Integer 

- 0; 

k: 

integer 

- 4; 

Ru1eEnd: 

integer 

- 9; 

r: 

integer 

- 1; 


number of states \ 

RuleEnd * 3 * (k - 1) } 
Range; number of neighbors } 


const 

Center = 2000; {center of fields} 

{ ********** start of procedures ******************* } 

\ -!- 1 

procedure DispIayMessage; 
beg i n 

GoToXY(1,25); 

Write('CELLULAR: by Kenneth E. Perry. 

Press Ins'); 

end; 

procedure DispIayStatusLine; 
beg i n 

GoToXY(1,25); 

Wr i te(' '); 

GoToXY(1,25); 

Write(RuIe[0]); 
for I :* 1 to 3 do 
beg i n 

wr ite(* *); 

for J :* 1 to 3 do 

beg i n 

Write(RuIe[3*(1-1)+J]); 
end; 
end; 

Wr I te(' *); {4 spaces} 

Write(Bgnd); 

Writef' '); 

Write(Cwidth); 

end; {01s pIayStatusLine} 
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J-2-! 

procedure DispIayGenerations; 
j compute and display 190 generations 
( or rows of cel Is ) } 
beg i n 

for V :* Vstart to Vfinish do 
{ number of generations to display } 
begin 

{ show display field } 
if Delta = 1 then 
begin 

for H :» Hstart to Hfinish do 
begin 

I :* H + Dstart; { display one generation } 
plot(H,V,Afield[IJ); 
end; 
end; 

if Delta - 2 then 
begin 

for H :« Hstart to Hfinish do 
begin 

I :* H + Dstart; 
plot(H+H,V+V,AfieId[I]); 
end; 
end; 

{ check for overflow of COMPUTE FIELD } 

If Widen * 1 then 
begin 

I :* Cstart; 

J :■ Cfin 1sh ; 

if (AfIeId[I] <> AfieId[I + 1]) or (AfIeId[J - 1] 

<> AfieId[J]5 then 
begin 

Cstart :» Cstart - 1; j this is to avoid end effects } 
Cfinish :» Cfinish + 1; 

Cwidth :« Cfinish - Cstart; 
end; 
end; 


{compute new row of cells and place in Bfield } 

for I :» Cstart to Cfinish do 
begin 

N AfieId[I-1] + Afield[I] + Af ield[I+l]; 

BfieId[I] Rule[N]; 
end; 


{return Bfield to Afield} 
for I :■ Cstart to Cfinish do 
beg 1 n 

AfieId[I] :« BfieId[I]; 
end; 

end; {for} 

end; { DispIayGenerations } 

j-3-} 

procedure ReadRuIeFromFiIe; 

begin {read rule from file ’DEMO-C.DOC* into ’Line’} 
Read In(F1IVar.Line); 

GotoXY(1,25); 

Writeln(Llne); { display rule on bottom 
line of screen } 

J :« 0; 

for I 1 to 13 do 
begin 

C :» Copy(Line,I,1); j copy rule, one digit at a time } 

If (C <> * ') then { skipping spaces } 

begin 

VaI(C,M,Nlx); 


(continued) 
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Rule[J] :■ M; j copy rule from 'Line' Into 'Rule* \ 
J J + 1; 
end; 
end; 

end; j ReodRuIeFromFI Ie { 

j-4-! 

procedure GetRondomRuIe; 


beg i n 


Ru 1 e 

0' 

;■ 0; 


Ru 1 e 

' 1' 

:* Random(k) 


Ru 1 e 

2 

:» Random! 

k 


Ru 1 e 

'3' 

:■ Random! 

Jk] 


Ru 1 e 

’4' 

:* Random! 


1 

Ru 1 e 

Y 

:* Random! 

!k] 

1 

Ru 1 e 

6 

Random! 

'k' 

) 

Ru 1 e 

’7' 

:« Random! 

iki 

) 

Ru 1 e 

8' 

:■ Random! 

;k; 

) 

Ru 1 e 

V 

:■ Randoml 

(k! 

) 


end; ] GetRondomRuIe j 


1-5-1 

procedure ChangeRule; 
beg i n 

RuIe[0l :« 0; 

GoToXY(3,25); 

for I :■ 1 to 11 do 

begin 

Wrlte(* •); 
end; 

GotoXY(3,25); 

for I :■ 1 to RuleEnd do 

begin 

Read(Kbd.C); 

Va I(C,M,X); 

Ru I e[I] M; 

Wrlte(RuIe[I]); 
end; 

DieplayStatusLine; 
end; \ ChangeRule | 


J- 6 -} 

procedure Initial IzeAinitToBackground; 
begin 

for I :« 0 to 4000 do 
begin 

Ain 11[I] Bgnd; 
end; 
end; 


|- 7 -1 

procedure In 111 a I IzeAlnItRandom; 
beg I n 

{ random initialize of COMPUTE FIELD in Ainitf 
for I :* Cstart to Cfinish do 
beg i n 

AI n i t[I] :* Random(k); 
end; 

end; { Ini11 a IizeAinItRandom \ 

j- 8 -1 

procedure MoveAinitToAfieId; 
beg i n 

for I 0 to 4000 do 
begin 

AfIeId[I] AinIt[I]; 
end; 

end; 

\ -9- \ 

procedure InitializeAlnitFromKeyboard; 
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begin 

Initial 1zeAinitToBackground; 

GraphCoIorMode; 

DeIay(400); 

Di spIayStatusLine; 

Plot(160,2,1); {display pixel cursor on "line 2" } 

For I := 0 to (319 div Delta) do 
begin 

Plot(I*Delta,0,bgnd); { show background on "line 0" } 
end; 


M 

N 

C 


Center; 

160 div Delta; 


repeat 

if keypressed then 
beg i n 

Read(Kbd.C); 

if (Co #27) and (C <> #42) then 
beg i n 

PIot(N * Delta,2,0); { erase pixel cursor } 

vaI(C,P,Nix); { C is String[1], P is integer } 

Ainit[M] :« P; 

PI ot(N * Delta,0,P); 

M :« M + 1; 

N :» N + 1; 

PIot(N * Delta,2,1); { write new pixel cursor } 
end; 

1f (C ■ #27) and keypressed then 
begin 

PlotfN * Delta.2,0); 

Read(Kbd.C); 

if (C - #75) then { left arrow \ 
begin 

M M - 1; 

N :* N - 1; 

end; 

if (C - #77) then { right arrow { 
begin 

M M + 1; 

N N + 1; 

end; 

PIot(N * Delta.2.1); 
end; 
end; 

until (C - #42); { * on keypad { 

Widen 1; 

MoveAlnitToAfieId; 

DispIayGenerations; 

end; { Initial 1zeAinitFromKeyboard } 

j-10- \ 

procedure SetBackground; 
begin 

read(Kbd.C); 

VaI(C.M.X); 

Bgnd :« M; 

DispIayStatusLIne; 
end; 

i--$ 

procedure StartFlnish; 
begin 

Cstart Center - (Cwidth div 2); 

Cfinish Center + (Cwidth div 2) - 1; 

Dstart Center - (Dwidth div 2); 

Dflnlsh :■ Center + (Dwidth div 2) - 1; 
end; 


12 


$ 


[continued) 
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procedure Fleld80X47; 
begin 

GrophColorMode; 

Dwidth 80; 

Cwidth 80; 

StartFInIsh; 

Vetart 0; 

Vflnish 48; 

Hstart :« 0; 

Hfinlsh 79; 

Delta :• 2; 

Del ay(400); 

Di8playStatu8Line; 

end; 

!-13-j 

procedure Field160X95; 
beg I n 

GraphColorMode; 

Dwidth :« 160; 

Cwidth 160; 

StartFlnlsh; 

Vstart 0; 

Vflnish 94; 

Hstart :■ 0; 

Hflnish 159; 

Delta 2; 

Delay(400); 

DisplayStatusLine; 

end; 

I-14-1 

procedure FieId320X190; 
begin 

GraphColorMode; 

Dwidth :« 320; 

Cwidth 320; 

StartFinish; 

Vstart :* 0; 

Vflnish 189; 

Hstart 0; 

Hf inish 319; 

Delta := 1; 

DeIay(400); 

DisplayStatusLine; 

end; 


| ************* end of procedures ***************** 


| ************** MAIN PROGRAM ************************ 


beg i n 

Ch :* • *; 

GraphColorMode; 

Pa Iette(0); 

Randomize; 

Fie Id160X95; 

DisplayMessage; 

repeat 

If KeyPressed “then 

begin {keypad symbols} 


502 BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 








December 


Read(Kbd.Ch); 

if (Ch - #45) then $ - { 

begin 

InitializeAlnitFromKeyboard 
end; 


if (Ch - #43) then f + } 

begin { Continue Structure } 

DispIayStatusLine; 

DispIayGenerations; 
end; 


{escape sequences} 

if (Ch * #27) and KeyPressed then {one more char?} 
begin 

Read(Kbd.Ch); 

if (Ch * #82) then { ins } 

begin { Random Rule Random Inititialize } 

Widen :* 0; 

GetRandomRuIe; 

Di spIayStatusLine; 

InitializeAinitToBackground; 

InitializeAinitRandom; 

MoveAinitToAfield; 

DispIayGenerations; 
end; 

if (Ch - #83) then { del } 

begin { Same Rule Random Inititialize } 

Widen ;■ 0; 

DispIayStatusLIne; 

InitializeAinitToBackground; 

InitializeAinitRandom; 

MoveAinitToAfield; 

DispIayGeneratIons; 
end; 


{function keys} 

if (Ch - #59) then { FI } 

beg i n 

ChangeRuIe; 
end; 

if (Ch - #60) then { F2 } 

beg i n 

SetBackground; 

end; 

If (Ch - #61) then { F3 } 

beg i n 

end; 


if (Ch - #66) then { F8 } 

beg i n 

Field80X47; 
end; 

if (Ch - #67) then { F9 } 

beg i n 

field160X95; 
end; 

if (Ch - #68) then { F10 } 

begin 

FIeId320X190; 
end; 

end; { if (Ch - #27 } 
end; { If keypressed } 

( continued ) 


BYTE LISTINGS SUPPLEMENT • OCTOBER-DECEMBER. 1986 503 







December 

until Ch « #13; j Return } j end repeat } 


end. 


DEMO 1.DOC 

"Abstract Mathematical Art," by Kenneth E. Perry, December 1986, page 181. 
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DEMO 2.DOC 

"Abstract Mathematical Art," by Kenneth E. Perry, December 1986, page 181. 


This Is DEMO-2.DOC 


NOTE; Rules are always stated as shown 
SUM 0123456789 

RULE 0010332321 (le. 

In other words the Rule, or next state, 
array that indexes from left to right. 


in the following example; 

next state) 
is an integer 


DEMOI 
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DEMONSTRATION OF SIMPLE CYCLIC STRUCTURES 

2 eye Iic structures. 

0123333300000000000000000003332023333 

3 eye Iic structures 
3313131333333333320233333333331113333 
a cyclic structure and a glider 
2203332112333022222222220223012222222 
a structure that generates 2 gliders 
0000000000000000011000000000000000000 
a serpentine structure and a glider 
3322210333333331123213333333333333333 
2 gliders 

1111112203211111111112032111111111111 
more cyclic structures 
0222303222002222211300000100000000000 
0032010102300000032200000000200000000 
0011000000002200000000002220000000000 
0000000000000000001000000000000000000 
3333333333332000000233333333333333333 
0111003000000000111110000000000300111 
SOME UNUSUAL CONSTANT WIDTH CYCLIC STRUCTURES. 
3220233220202332202020233220202020233 
3220202020202332202020202020233333333 
3220202020202020233220202020202020202 
3333233333333333333333331110001113333 

A "FABRIC". THIS STRUCTURE CAN BE MADE ARBITRARILY WIDE. 
3311100011100011100011100011100011133 











December 


0 210 003 311 
0 302 103 303 
0 310 230 210 


ANOTHER FABRIC. THIS RULE IS WORTH INVESTIGATING FURTHER 
0033002112002112002112002112003300000 
0022333333320000000000000000000002220 
0011100000000000000000000002330221000 


DEM02 DEMONSTRATION OF MORE COMPLEX CYCLIC STRUCTURES 

320 X 200 PIXEL SCREEN 


0 201 130 000 
0 330 102 221 
0 001 333 021 
0 201 131 030 
0 201 022 312 

0 031 230 102 


0 201 320 200 


0000000000000001001000000000000000000 
0000000220000000000000000002200000000 
0000000000031111111111113000000000000 
0000000000000101010101000000000000000 
0000000000000033322221000000000000000 
FOR BELOW RULE SEE ALSO GLIDERS 
0000000000000111000001110000000000000 

THIS IS A CYCLIC (PERSISTENT) STRUCTURE THOUGH IT DOESN’T 
LOOK IT. THE PERIOD IS ABOUT 860 GENERATIONS. 
0000000000002222222010200000000000000 


DEM03 DEMONSTRATION OF SELF SIMILAR TRIANGLES 

320 X 200 PIXEL SCREEN 


0 110 331 310 
0 223 032 232 
0 103 203 000 
0 120 323 030 
0 103 022 021 
0 220 303 101 
0 102 210 000 
0 213 003 103 
0 203 010 302 
0 012 013 012 
0 031 311 022 


SELF-SIMILAR TRIANGLES 
0000000000000000010000000000000000000 
0000000000000000020000000000000000000 
0000000000000000030000000000000000000 
0000000000000000020000000000000000000 
0000000000000000010000000000000000000 
0000000000000000020000000000000000000 
0000000000000000010000000000000000000 
3333333333333331000133333333333333333 
0000000000000000030000000000000000000 
0000000000000000020000000000000000000 
1111111111111113333331111111111111111 


DEM04 DEMONSTRATION OF VARIOUS KINDS OF GLIDERS 

320 X 200 PIXEL SCREEN 

SLOW GLIDERS 


0 310 023 012 

0 002 313 010 
0 130 301 233 

0 031 230 102 

0 130 300 331 

0 201 113 330 

0 310 202 332 


0000322100000000000000000000122300000 
STRANGE GLIDERS 

0000000000000003322000000000000000000 
3323113333333333333333333333333333333 

THE FOLLOWING RULE SUPPORTS MANY OTHER CYCLIC STRUCTURES 
0012200000000000000000000000002113000 
THE FOLLOWING SHOWS CROSSING GLIDERS 
0100000000010000000001000000000100000 
ANOTHER STRANGE GLIDER 
0011333120000000000000000000000000000 
A GLIDER THAT GENERATES CHAOS 
0000000000000022223300000000000000000 


DEM05 METHESULAS 320 X 200 PIXEL SCREEN 


The term "Methesula" is borrowed from the "Game of Life" and describes c 
structure that grows slowly and lives for many generations (or ticks c‘ -*e 
clock), but eventually comes to an end, either by dying out co^c et* :* 
degenerating into a number of simple cyclic stuctures. Con you ‘ -r z 
Methesula that lives more thon 3000 generations? 5000? 10000? As:- 
growing, long lived structure for which no end hos been found is z •»* 
the provisional name of "eternal". 

Try this experiment: Invoke CELLULAR; strike key FI and enter c-e :* v*e 
following rules, then type (F8),(DeI),(F10),( + ),( + ),( ♦ ). 

The structure will grow slowly, if at all, but will not dege-e-c-s •:* : 
long time. To moke a Methesula you must find the symmetric: * s 

prettier) initial condition that gives the longest living s:-.:*.-* 

METHUSALEHS 

SS&ttUr' ( continued ) 


■IHV • 
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0 201 210 313 

0 030 321 323 

0 010 332 321 

0 302 103 213 

0 310 203 122 

0 201 123 102 
» 

0 201 123 102 

0 012 031 213 
• 

• DEM06 


LIVES 750 GENERATIONS 
0000000000000033333333330000000000000 
LIVES 692 GENERATIONS (squareish appearance) 
0000000333333333332333333333330000000 
LIVES 2870 GENERATIONS 
0000000000000002222222000000000000000 
LIVES 2230 GENERATIONS 
0000222222222222222222222222222220000 
LIVES 1900 GENERATIONS 
0000000000200000000000000200000000000 
LIVES 2700 GENERATIONS 
0000111000000000011100000000001110000 
I HAVE FOUND NO END TO THIS ONE SO IT MAY BE ETERNAL. 
BUT IT'S PRETTY TO WATCH. 

0011100000000000011100000000000011100 
FIGURE THIS ONE OUT. 

0000000000000000011100000000000000000 


DEMONSTRATION OF GLIDER GUNS 


320 X 200 PIXEL SCREEN 


• 

0 

020 

303 

102 

0 

310 

103 

031 

0 

330 

022 

123 

0 

020 

133 

033 

0 

120 

303 

310 

0 

021 

033 

013 

0 

113 

203 

023 


GLIDER GUNS 

0000000000000000202000000000000000000 
0000000000000001133110000000000000000 
0000000000000000020000000000000000000 
0000000000000000020000000000000000000 
0000000000000001111100000000000000000 
0000000000000000020000000000000000000 
3333333333333333323333333333333333333 


DEM07 CLASS 4 TRIANGLES AND RETRO-FIRING GLIDERS 

SPEED OF EXPANSION - 1 
320 X 200 PIXEL SCREEN 


» 

0 

203 

220 

121 

» 

0 

203 

220 

121 

• 

0 

203 

220 

121 

! 

0 

203 

220 

121 

* 

0 

* 

203 

220 

121 

» 

0 

210 

310 

320 

0 

303 

022 

100 

0 

102 

301 

031 

! 

0 

013 

001 

121 

0 

020 

303 

302 


RETRO-FIRING GLIDERS. GENESIS OF CLASS 4 TRIANGLES 
-GLIDER #1 

0000000000000000000i23000000000000000 

-GLIDER #2 RETRO-FIRES GLIDER #1 

0000000000000000001203000000000000000 

-GLIDER #3 RETRO-FIRES GLIDER #2 WHICH RETRO-FIRES GLIDER #1 

0000000000000001202101230000000000000 

-CLASS 4 TRIANGLE CONTROLLED BY GLIDER #2 

0000000000000000003000000000000000000 

-CLASS 4 TRIANGLE CONTROLLED BY GLIDER #3 

0000000000000000032300000000000000000 

CLASS 4 TRIANGLES 

0000000000000000002000000000000000000 
0000000000000000003000000000000000000 
0000000000000000001000000000000000000 
INSTANT OVERPOPULATION 
0000000000000000003000000000000000000 
0000000000000000002000000000000000000 


DEM08 CLASS 4 TRIANGLES. SPEEO OF EXPANSION LESS THAN 1 


SPEED OF EXPANSION LESS THAN 1 
320 X 200 PIXEL SCREEN 


0 

310 

202 

111 

0 

230 

103 

201 

0 

201 

322 

002 

0 

202 

330 

313 

0 

201 

311 

202 


0000000000000000010000000000000000000 
0000000000000000020000000000000000000 
0000000000000002121200000000000000000 
0000000003030303030303030300000000000 
GOOD FOR 600 GENERATIONS 
0000000000000000010000000000000000000 


AN UNUSUAL STRUCTURE THAT GROWS AT A SLOW BUT CONSTANT RATE 
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0 310 230 033 0000000000000000202000000000000000000 


DEM09 MORE CLASS 4 TRIANGLES 

320 X 200 PIXEL SCREEN 


0 020 133 320 
0 020 213 310 
0 323 013 023 
0 120 303 001 
0 103 220 113 
0 020 330 213 
0 021 033 000 
0 013 102 002 
0 020 033 132 
0 120 033 012 
0 020 233 020 
0 013 020 220 
0 102 301 002 
0 320 330 021 
0 021 302 210 
0 020 013 332 


MORE CLASS 4 TRIANGLES 
0000000000000000220000000000000000000 
0000000000000000020000000000000000000 
3333333333333333323333333333333333333 
0000000000000000020000000000000000000 
0000000000000000010000000000000000000 
0000000000000000232000000000000000000 
0000000000000000220000000000000000000 
0000000000000000030000000000000000000 
0000000000000000020000000000000000000 
0000000000000000020000000000000000000 
0000000000000000020000000000000000000 
0000000000000003222300000000000000000 
0000000000000001221000000000000000000 
0000000000000000020000000000000000000 
2222222222222211111112222222222222222 
0000000000000000020000000000000000000 


DEMO ONE.PAS 

"Abstract Mathematical Art," by Kenneth E. Perry, December 1986, page 181. 


program DemoOne; 

{one dimensional cellular automata } 
var 

FilVar: text; 

Line: string[20]; 

C: str1ng[1]; 


Ainit: array[0..4000] of byte; 

{4001 cells wide. Allows for} 
Afield: array[0..4000] of byte; 

{ expansion of COMPUTE FIELD } 
Bfield: array[0..40001 of byte; 

Rule: array[0..12] of byte; 

I,J,M,N,H,P,V,X,Nlx: integer; 

Ch: char; 


Delta: 

integer; I 

pixel 

spacing 1, or 2 j 

Dwidth: 

Integer; 

width 

of display field } 

Cwidth: 

Integer; 

width 

of compute field j 

Cstart: 

integer; j 

i COMPUTE FIELD, start with a 

CfInish: 

integer; j 

j width 

of 160 } 

Dstart: 

Integer; { display field } 

Df inish: 

integer; 



Vstart: 

integer; ■ 

{ vertical display } 

Vf inish: 

integer; 



Hstart: 

integer; 

{ horizontal display } 

HfIn 1sh: 

integer; 



const | 

typed constants } 


1 

these are essential 

ly initialized varlab 

Widen: 

Integer » 

- 0; 


Bgnd: 

Integer « 

= 0; 


k: 

integer 1 

“ 4; 

number of states } 

Ru1eEnti 

1: integer 

- 9; 

RuleEnd * 3 * (k - 

r: 

integer 

- 1; 

Range; number of nei 


\ 


{continued) 
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const 

Center ■ 2000; {center of fields} 

{ ********** start of procedures **************** } 

I-1-j 

procedure DisplayMessage; 
begin 

GoToXY(1, 25); 

Wr1te(* DEMO-ONE: by Kenneth E. Perry. 

Press Ins'); 
end; 

procedure OisplayStatusLIne; 
beg i n 

GoToXY(1,25); 

Write(* *); 

GoToXY(1,25); 

Wr1te(RuIe[0]); 
for I :* 1 to 3 do 
beg i n 

write(’ ’); 

for J ;■ 1 to 3 do 

begin 

wrIte(RuIe[3*(1-1)+J]); 
end; 
end; 

{ WriteC *); 

Wr i te(Bgnd); 

Writef* ’); 

Write(Cwldth); { 

end; {DisplayStatusLInef 

|-2-1 

procedure DisplayGenerations; 

! compute and display 190 generations 
or rows of cells ) } 
beg i n 

for V :■ Vstart to Vfinish do 
{ number of generations to display } 
begin 

{ show display field } 
if Delta = 1 then 
begin 

for H := Hstart to Hfinish do 
begin 

I :«= H + Dstart; { display one generation } 
plot (H,V,Af i eld[I]); 
end; 
end; 

if Delta * 2 then 
beg i n 

for H := Hstart to Hfinish do 
beg i n 

I := H + Dstart; 
plot(H+H,V+V,AfieId[I]); 
end; 
end; 

{ check for overflow of COMPUTE FIELD } 

if Widen - 1 then 
begin 

I :« Cstart; 

J :«■ Cflnlsh; 

If (AfleId[I] <> AfIeId[I + ll) or 
(AfieId[J - 1] <> Afield[JJ) then 
beg i n 

Cstart Cstart - 1; 

{ this is to avoid end effects } 
Cfinish :* Cfinish + 1; 

Cwidth :* Cfinish - Cstart; 
end; 
end; 
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{compute new row of cells and place in Bfield { 

for I :« Cstart to Cfinish do 
beg I n 

N Afield[I-1] + Afield[I] + Afield[I+1]; 
Bfield[I] Rule[N]; 
end; 


{return Bfield to Afield} 
for I ;• Cstart to Cfinish do 
beg i n 

Af ieId[I] BfieId[I]; 
end; 

end; {for} 

end; { DispIayGenerations } 

I-3-1 

procedure ReadRuIeFromFiIe; 

begin {read rule from file 'DEMO-C.DOC into ’Line’} 
Read In(F1 IVar,Line); 

J :« 0; 

for I ;■ 1 to 13 do 
begin 

C :* Copy(Line,I,1); 

{ copy rule, one digit at a time } 

if (C <> * *) then { skipping spaces } 

begin 

VaI(C,M,Nix); 

{ value of String[1] C placed in integer M } 
RuIe[J] M; 

{ copy rule from ’Line* into 'Rule* } 

J :* J + 1; 
end; 
end; 

end; { ReadRuIeFromFiIe } 

i-6-1 

procedure InitializeAinitToBackground; 
begin 

for I :■ 0 to 4000 do 
begin 

Ainit[I] :« Bgnd; 
end; 
end; 


j-7-} 

procedure In 111 a I 1zeAlnItRandom; 
beg i n 

{ random initialize of COMPUTE FIELD in AinIt| 
for I :* Cstart to Cfinish do 
beg i n 

Ainit[I] :* Random(k); 
end; 

end; { InitializeAinitRandom } 

j-8- ) 

procedure MoveAinltToAfield; 
begin 

for I :* 0 to 4000 do 
begin 

Afteld[I] Ainit[I]; 
end; 

end; 


i-ii-1 

procedure StartFinish; 

( continued ) 
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begin 

Cstart Center - (Cwldth dlv 2); 

CfIn Ish Center + (Cwidth dlv 2) - 1; 
Dstart :* Center - (Dwidth dlv 2); 
Dflnleh :■ Center ♦ (Dwidth div 2) - 1; 
end; 


j-13-j 

procedure FieId160X95; 
begin 

GraphColorMode; 

Dwidth :« 160; 

Cwidth ;* 160; 

StartFInish; 

Vstart :■ 0; 

Vflnish :■ 94; 

Hstart :■ 0; 

Hf Inieh 159; 

Delta ;■ 2; 

Del ay(400); 

DisplayStatusLIne; 

end; 

i-u- \ 

procedure FieId320X190; 
begin 

GraphCoIorMode; 

Dwidth 320; 

Cwidth 320; 

StartFinish; 

Vstart :• 0; 

Vflnish 189; 

Hstart :* 0; 

Hf Inish 319; 

Delta :■ 1; 

DeIay(400); 
end; 


j ************** 6nc | 0 f procedures **************** 
\ ************** MAIN PROGRAM ********************** j 


beg I n 

Ch :« • »; 
GraphColorMode; 
Pa Iette(0); 
Randomize; 

F i eId320X190; 

DispIayMessage; 


Assign(FI IVar,'DEMO-1.DOC’); 

Reset(FiIVar); 

repeat 

if KeyPressed then 

begin {keypad symbols} 

Read(Kbd.Ch); 

1f (Ch - #45) then } - } 

begin 

end; 
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If (Ch - #43) then I + j 

begin { Continue Structure } 

DisplayStatusLine; 

DispIayGenerations; 
end; 

{escape sequences} 

If (Ch * #27) and KeyPressed then {one more char?} 
beg i n 

Read(Kbd.Ch); 

if (Ch = #82) then { ins } 

begin { new rule random initialize } 

Widen :« 0; 

ReadRuIeFromFiIe; 

DisplayStatusLine; 

InitializeAinitToBackground; 

InitializeAinitRandom; 

MoveAinitToAfieId; 

Di spIayGenerations; 
end; 

if (Ch = #83) then { del } 

begin { Same Rule Random Inititialize } 

Widen :* 0; 

DispIayStatusLine; 

InitializeAinitRandom; 

MoveAinitToAfieId; 

DisplayGenerations; 
end; 


{function keys} 


if (Ch - #59) then 

beg i n 

end; 

1 FI I 

if (Ch * #60) then 

begin 

end; 

1 F2 } 

if (Ch = #61) then 

beg i n 

end; 

1 F3 \ 

if (Ch - #66) then 

beg i n 

end; 

I F8 | 

if (Ch - #67) then 
beg i n 

field160X95; 
end; 

| F9 | 

if (Ch - #68) then 
beg 1 n 

Field320X190; 

end; 

| F10 

end; { if (Ch - #27 } 
end; { if keypressed } 
unt11 Ch ■ #13; { Return } 

j end repeat 


end. 


[continued] 
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DEMO TWO.PAS 

"Abstract Mathematical Art," by Kenneth E. Perry, December 1986, page 181. 


program DemoTwo; 

{one dimensional cellular automata } 
var 

FiIVar: text; 

Line: strlng[20]; 

C: string[l]; 

Ainit: array[0..4000] of byte; 

{4001 cells wide. Allows for} 
Afield: array[0..4000] of byte; 

{ expansion of COMPUTE FIELD } 
Bfield: array[0..4000] of byte; 

Rule: array[0..12J of byte; 

I,J,M,N,H,P,V,X,Nlx: integer; 


Ch: 


char; 


Delta: 

integer; 

| pixel spacing 1, or 

2 ! 

Dwidth: 

Integer; 

| width of display fie 

Id } 

Cwldth: 

Integer; 

{ width of compute fie 

Id } 

Cstart: 

integer; 

j COMPUTE FIELD, start 

with a } 

Cfinish: 

Integer; 

{ width of 160 } 


Dstart: 

integer; 

{ display field } 


Dfinish: 

integer; 



Vstart: 

integer; 

{ vertical display } 


Vfinish: 

integer; 



Hstart: 

integer; 

{ horizontal display } 


Hfinish: 

integer; 




const | typed constants } 

| these are essentially initialized variables } 


Widen: 

Integer 

- 0; 

Bgnd: 

Integer 

= 0; 

k: 

integer 

« 4; 

Ru1eEnd: 

integer 

* 9; 

r: 

1nteger 

= i; 


number of states } 

RuleEnd = 3 * (k - 1) } 
Range; number of neighbors } 


const 

Center = 2000; {center of fields} 

{ ********** start of procedures **************** } 

j-1-1 

procedure DispIayMessage; 
beg i n 

GoToXY(1,25); 

Write(* DEMO-ONE: by Kenneth E. Perry. 

Press Ins’); 
end; 

procedure DispIayStatusLine; 
beg i n 

GoToXY(1,25); 

Write(' ’); 

GoToXY(1,25); 

Wr1te(RuIe[0]); 
for I :» 1 to 3 do 
begin 

write(’ ’); 

for J :■ 1 to 3 do 

begin 

wrIte(RuIe[3*(1-1)+J]); 
end; 
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end; 

{ Write(’ *); 

Wr i te(Bgnd); 

Writer • V 
Write(Cwidth); } 

end; {DispIayStatusLine} 

\ - 2 -! 

procedure DispIayGenerations; 

| compute and display 190 generations 

( or rows of cells ) } 

begin 

for V :* Vstart to Vfinish do 
{ number of generations to display } 
begin 

{ show display field } 
if Delta * 1 then 
beg i n 

for H := Hstart to Hfinish do 
beg i n 

I :« H + Dstart; { display one generation } 
plot(H,V,Afield[I]); 
end; 
end; 

if Delta « 2 then 
begin 

for H := Hstart to Hfinish do 
beg i n 

I :* H + Dstart; 
plot(H+H,V+V,Afteld[I]); 
end; 
end; 

{ check for overflow of COMPUTE FIELD \ 

if Widen - 1 then 
beg i n 

I :» Cstart; 

J :■ Cfinish; 

if (AfieId[I] <> AfieId[I + 1]) or 
(AfieId[J - 1] <> AfieId[JJ) then 
begin 

Cstart Cstart - 1; 

j this is to avoid end effects } 
Cfinish :« Cfinish + 1; 

Cwidth Cfinish - Cstart; 

end; 
end; 

{compute new row of cells and place in Bfield } 

for I := Cstart to Cfinish do 
beg i n 

N AfIeId[I-1] + Afield[I] + Af1eld[I+1]; 

Bfield[I] := Rule[N]; 
end; 


{return Bfield to Afield} 
for I :* Cstart to Cfinish do 
beg i n 

Af ieId[I] Bfield[I]; 
end; 

end; {for} 

end; { DispIayGenerations } 

{- 6 - 1 

procedure InitializeAlnItToBackground; 
begin 

for I ;■ 0 to 4000 do 
begin 

Ain 11[I] Bgnd; 
end; 

en ^ ; ( continued ) 
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j- 3 -j 

procedure ReodRuIeFromFI Ie; 

begin {read rule from file ’DEMO-C.DOC' into 'Line’ 
Readln(FiIVar.Line); 

J :« 0; 

for I :■ 1 to 13 do 
beg i n 

C :* Copy(LIne,1*1); 

{ copy rule, one digit at a time ( 

if (C <> • ') then { skipping spaces \ 

begin 

VaI(C.M.Nix); 

{ value of Stringfl] C placed in integer M } 
Ru I e[J] M; 

{ copy rule from ’Line* into ’Rule’ | 

J J + 1; 
end; 
end; 

end; { ReadRuIeFromFI Ie } 

{- 7 - 1 

procedure Initia IizeAinItRandom; 
begin 

{ random Initialize of COMPUTE FIELD In Ainitj 
for I :■ Cstart to Cflnish do 
begin 

AInit[I] :* Random(k); 
end; 

end; { In 111 a I IzeAinItRandom } 

j- 8 -j 

procedure MoveAinitToAfieId; 
begin 

for I :■ 0 to 4000 do 
begin 

AfIeId[I] AlnIt[I]; 
end; 

end; 


i-ii-1 

procedure StartFinish; 
beg i n 

Cstart :• Center - (Cwidth dlv 2); 
Cfinish :« Center + (Cwidth dlv 2) - 1; 
Dstart :« Center - (Dwidth dlv 2); 
Dfinlsh :* Center + (Dwidth div 2) - 1; 
end; 


j- 13 -1 

procedure Field160X95; 
beg i n 

GraphColorMode; 

Dwidth :« 160; 

Cwidth := 160; 

StartFinish; 

Vstart := 0; 

Vfinish 94; 

Hstart 0; 

Hfinish :* 159; 

Delta :* 2; 

Delay(400); 

DisplayStatusLine; 

end; 

j- 14 -1 

procedure Fie Id320X190; 
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beg i n 

GraphCoIorMode; 
Dwidth := 320; 
Cwidth :*= 320; 

StartFinish; 

Vs tart :* 0; 
Vfinish :* 189; 
Hstart :« 0; 
Hfinish :* 319; 
Delta :* 1; 

DeI ay(400); 
end; 


{ ************** end of procedures **************** } 
j ************** MAIN PROGRAM ********************** } 


beg i n 

Ch :*= # '; 
GraphCoIorMode; 
Pa Iette(0); 
Randomize; 
Field320X190; 

DispIayMessage; 


Ass 1gn(FiIVar,'DEMO-1.DOC’); 
Reset(F!IVar); 


repeat 

if KeyPressed then 
begin 

Read(Kbd.Ch); 
if (Ch = #45) then 
begin 
end; 


If (Ch - #43) then 
begin 

DisplayStatusLine; 
Di spIayGenerations; 
end; 


{keypad symbols} 
\ - \ 


{ Continue Structure } 


then {one more char?} 


{escape sequences} 

if (Ch - #27) and KeyPressed 
begin 

Read(Kbd.Ch); 


if (Ch « #82) then 
begin I new rule 

Widen :■ 0; 

ReadRuleFromFile; 
DisplayStatusLine; 

Initial IzeAinItToBackground; 
InitialIzeAinltRandom; 

MoveAinitToAfIeId; 

DispIayGenerations; 
end; 


} Ins } 

random initialize 


if (Ch - #83) then J del \ 

begin 

end; 





( continued ) 
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{function keys} 

if (Ch - #59) then } FI } 

begin 

end; 

if (Ch - #60) then { F2 } 

beg i n 

end; 

if (Ch - #61) then { F3 } 

beg i n 

end; 


if (Ch « #66) then { F8 } 

begin 

end; 

if (Ch - #67) then { F9 } 

begin 

fieldl60X95; 
end; 

if (Ch - #68) then { F10 } 

begin 

Field320X190; 

end; 

end; j if (Ch * #27 } 
end; { if keypressed } 
until Ch - #13; { Return } { end repeat { 

end. 


README.DOC 

"Abstract Mathematical Art," by Kenneth E. Perry, December 1986, page 181. 


FILE: README.DOC by Kenneth E. Perry 

Programming One-dimensional Cellula 

Automata 


The theory of one-dimensional automata Is 
described in my article in the December '86 issue of Byte 
magazine and will not be repeated here. That article was 
written in mid-1985, and does not reflect the new 
material discussed In this document. My interest in one- 
dimensional cellula automata was sparked on reading 
Stephen Wolfram's article "Computer Software in Science 
and Mathematics" in the September 1984 issue of 
Scientific American; about half of the article was 
devoted to this subject. Reading it (and especially 
looking at the stunning color reproductions of computer 
graphics) stimulated in me a strong desire to program 
these automata on my own computer. 

My first attempt was written in Basic; this turned 
out to be unacceptably slow. I then bit the bullet and 
wrote a program that was entirely in assembly language. 
This program was plenty fast enough and it served me well 
for some time - to the present moment (spring of 1986) it 
has allowed me to examine between 10 and 20 thousand of 
the quarter million possible 4-state rules - but it had 
the disadvantage of being machine specific. Due to the 
unique color graphics routines It contained, the program 
would run only on a Heath/Zenith Z-100 Computer. I 
recently acquired a Z-200 computer, a PC-AT eqivalent, (I 
am fiercely loyal to Heath computers; this is my third.) 
and decided to rewrite my program In the PC version of 
Turbo Pascal which will run on any PC or equivalent. I 
will now describe this program, called "CELLULAR", plus 
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two demonstration programs, "DEMO-ONE" AND "DEMO-TWO" 
which illustrate some of the best rules I have found over 
the past year or so. 


USING THE CELLULAR.COM PROGRAM 


When the CELLULAR progrom is invoked, the first 
thing to do is to strike the (Ins) key. This causes the 
first (random initialized) automaton to be displayed on 
the color screen; at the same time the status line will 
be displayed. The first ten digits are the 

(randomly generated) rule number; the next single Integer 
is the background state, usually zero. This value con be 
changed by using the F2 key and a numeric key. It Is 
used in the KEYBOARD INITIALIZE MODE to force a non-zero 
background. The last 3 digits form a decimal number 
Indicating the width of the COMPUTE FIELD of which more 
loter. Except for some function keys and the normal row 
of numeric keys, all keys that control the program are 
located near the right hand key-pad. 

Striking the (Del) key will display the same rule 
with different random Initialization; doing this several 
times often gives an insight into what the rule can do. 

At this point you can either continue striking (Ins) 

(getting more random rules) and watching the display 
until you find something interesting, or you can strike 
the FI function key. This will erase the displayed rule 
and position the cursor for entry of a new rule (without 
spaces) using the regular numeric keys on the main 
keyboard. With a specific new rule entered you con 
proceed just the some as after a random rule was given as 
explained In the next paragraph. 

If you follow the random seorch and find something 
interesting, shift to the (Del) and ( + ) keys to 
further examine the rule. The (Del) key allows you to re¬ 
examine the same rule with different random 
Initialization of the field of cells. The ( + ) key 
allows examining of further generations of the automaton 
beyond the bottom of the screen far removed from the 
random initial transient where the true nature of the 
automaton will often show Itself. You can now shift to 
the KEYBOARD INITIALIZE MODE by striking the ( - ) key. 

In this mode, the PIXEL CURSOR will appear in the 
center top of the screen Just below the INITIALIZE LINE 
which will display the color of the BACKGROUND shown on 
the status line. If the background is 0 there will, of 
course, be no visible initialize line. The left and 
right arrow keys will move the PIXEL CURSOR left and 
right. The numeric keys 0,1,2 and 3 place corresponding 
pixel values (black, green, red, brown) In the 
INITIALIZE LINE, and the PIXEL CURSOR will move one pixel 
to the right. If one of these keys is held down, the 
auto-repeat feature will cause the pixel cursor to slew 
to the right, laying down a string of pixels of the 
corresponding color. The spacing of the pixels will 
depend on which of the function keys, F8.F9.F10 is in 
control. If the line of cells overshoots the end of 
the screen, no harm is done. In the same way the 0 
numeric key con be used to erase all color cells from the 
Initialize line. Once the initialize line is the way you 
want it, press the ( * ) key to engender the automaton 
that is created by the rule and the initial state. In 
fact, this Is the only way to exit the KEYBOARD 
INITIALIZE MODE, and no other key Is effective until the 
screen is finished painting; this con be confusing if the 
screen is painting oil black. 

One feature of CELLULAR, In the keyboard Initialize 
mode, that may not at first be apparent to the user Is 
the expanding COMPUTE FIELD. This is the area In memory 

(continued) 
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where the cell values are stored and recomputed before 
being displayed. This starts out to be the same width 
as the displayed field, 160 cells or 320 or whatever, but 
memory is set aside so that the computation field can be 
any width up to 4000 cells. If a structure expands so 
that It threatens to exceed the original field width, the 
computation field expands (symmetrically) to keep ahead 
of the structure; this width is shown on the status 
line. Thus, although the structure may expand out of the 
visual field, It is still being computed correctly, and 
the part that Is displayed is true; edge effects are 
avoided. Of course, as the field width increases, the 
computation and display slows down, but not much since 
displaying the pixels takes up more time than computing. 
This is especially valuable in examining the developing 
central axis of class 4 triangles. 


SUMMARY OF CELLULAR FUNCTIONS 


You come up In the RANDOM SEARCH MODE 

There are 3 sets of keys used to control the program 

1. Seven "action" keys In the keypad area 

2. Four numeric keys 0, 1, 2, 3 

3. Five function keys that perform various functions 


KEYPAD KEYS IN RANDOM SEARCH MODE 

(Ins) Generates a new random rule and displays the 

screen from random initialization of the line of cell. 

(Del) Dispalys the same rule again with different 

random initialization. 

( + ) Displays more generations of the same rule. 

( - ) Places you in the KEYBOARD INITIALIZE MODE, 

the PIXEL CURSOR appears in the center top of the screen 
Just below the INITIALIZE LINE which will display the 
color of the BACKGROUND shown on the status line. If the 
background is 0 there will, of course, be no visible 
initialize line. 

( <- ) and ( -> ) arrows move the PIXEL CURSOR left and 
right 

Numeric keys 0,1,2 and 3 place corresponding pixel values 
(black, green, red, brown) in the INITIALIZE LINE; 

( * ) Displays the structures engendered by the RULE and 
the contents of the INITIALIZE LINE. 


FUNCTION KEYS 

The following keys may be struck any time the screen 
is not painting. The status line will show the changes 
made. 

FI Erases the displayed rule (but not the first digit 
which is always zero) and positions the cursor for entry 
of a new rule using the numeric keys (type without 
spaces) the new rule will appear on the status line. 

F2 Allows changing the background value which is usually 
0 but may be set to any value 0, 1, 2, 3. using the 
numeric keys. 

F8 Sets a screen of 80 by 50 pixels (CELLS) for a very 
quick look. 

F9 Sets a screen of 160 by 100 pixels for a quick look. 

F10 Sets a screen if 320 by 200 pixels for a better 
picture. 
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Striking return at any time when the screen is not 
painting, will exit from CELLULAR and return the system 
prompt. 


DEMONSTRATION PROGRAMS DEMO-ONE AND DEMO-TWO 

The demonstration programs on this disk illustrate 
some of the many kinds of structures that can be found 
in one-dimensional cellula automata. 

USING DEMO-ONE 

The DEMO-ONE.COM program reads a list of rules from 
the text file DEMO-1.DOC and displays the structures 
after random initialization of the line of cells. Many 
of these rules show a structure which I call a "Boundary 
Glider", a propagating structure that forms a boundary 
between regions of different background states. 

When the DEMO-ONE program is invoked, the screen is 
blanked. The following keys control the program: 

1. The (Ins) key will cause the structure of the first 
(or next) rule to be displayed after random 
initialization. The rule number will be displayed on the 
status line. 

2. The (Del) key will redisplay the structure of a rule 
with a new random initialzion 

3. The ( + ) key will continue the display of 
succeeding generations of the structure. 

4. The F9 and F10 keys can be used to change the 
resolution of the display field as described above. 


USING DEMO-TWO 


The program DEMO-TWO.COM reads rules and initial 
conditions from the text file DEMO-2.DOC. This file is 
heavily commented, and it is a good idea to have a 
printout of it beside you as you go through this program. 
The contents of the various sections of DEMO-2.DOC are as 
foilows: 


DEM01 

structures. 
DEM02 

structures. 
DEM03 
DEM04 
gIiders. 

DEM05 

these) 

DEMOS 

DEM07 

GLIDERS. Speed 
DEM08 

less than 1 
DEM09 


Demonstration of simple cyclic 

Demonstration of more complex cyclic 

Demonstration of self similar triangles. 
Demonstration of various kinds of 

METHESULAS. (use the ( + ) key to follow 

GLIDER GUNS. 

CLASS 4 TRIANGLES and RETRO-FIRING 
■ 1 , 

CLASS 4 TRIANGLES. Speed of expansion 

More CLASS 4 TRIANGLES. Speed * 1 


When the DEMO-TWO program is envoked the status line 
will appear at the bottom of the screen. Operation of 
DEMO-TWO is similar to DEMO-ONE except that random 
initialization is not used, and the (Del) key has no 
effect. In either DEMO mode you can press F9 to go 
through the rules faster. 

I wiI I describe some of the structures that are to 
be found in DEMO-ONE and DEMO-TWO. As I mentioned, the 
DEMO-ONE structures are all Initialized in the random 
state. I had been keeping a list of rules that seemed to 
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show to best effect when rondomly initialized. One day I 
noticed that many of these displays contained a structure 
that I had not recognized before and which could hove 
only one name, "Boundary Gliders", that is, propagating 
structures that formed boundaries between regions of 
different background colors. A number of these structures 
will be found In OEMO-ONE and these ore often responsible 
for very striking visual effects. 

The text file DEMO-2.DOC, which supplies the rules 
and Initial conditions for program DEMO-TWO, is rather 
heavily commented and is divided Into 9 "chapters" DEM01 
through DEM09. DEM01 shows a variety of simple cyclic 
structures such as we have discussed before; o few are 
rather unusual. DEM02 shows more complex cyclic 
structures of longer period. 

DEM03 shows "self-similar triongles"; these are 
structures that expand at a constant speed (usually the 
speed of light; speed = 1, but sometimes 1/2, 1/3, 2/3, 
etc.) and hence show a triangular structure. Within, are 
generated triangular forms that appear larger and larger 
as the the structure grows, but which all look the some 
except for being different In size, thus self-similar. 

The first three structures are truly self-similar 
because, If you Ignore the individual pixels, there is 
nothing to give a scale of size. Strictly speaking, most 
of the other structures are not truly self-similar, but 
this makes then prettier, I think. 

DEM04 displays some gliders specially selected for 
unusual or wierd effects. Some perioicolly bud off other 
structures at a constant rate. 

DEM05 contains a number of "Methuselos", a term 
borrowed from the Game of Life. These structures grow 
very slowly and last for hundreds or thousands of 
generations before degenerating into a few simple cyclic 
structures (or dying out completely). I consider these 
to be the most interesting - besides being among the 
hardest to find - of all structures of one-dimensional 
cel IuI a automata. Follow these to the end by using the ( 
+ ) key. I think you will find It an Interesting 
experIence. 

DEM06, "Glider Guns", are stationary structures that 
periodically shoot off gliders. Since the stationary 
structures are symmetrical the gliders fire in both 
directions. As you go down the list you will see the 
pictures becomming more and more "Baroque". 

CLASS 4 TRIANGLES have the the same external form as 
the self-similar triangles mentioned above but the 
internal structure is anything but self-similar. I have 
found so many of them that they fill DEM07, DEM08, and 
DEM09; in fact they are the easiest to find of all the 
really complex class 4 structures. 

Class 3 triangles, now. Well, you know, this 

might be a good way to introduce the gome; try it. 

Invoke CELLULAR; strike (ins); if the display you get is 
not obviously class 1 or class 2, strike ( - ) then 
numeric key 1, 2, or 3 ( a single cell seed ) then ( * ). 
You should get a class 3 triangle. Sometimes the seed 
will not germinate, in which case try a different key. 

The triangle will always be symmetrical so the effects 
are usually more or less pretty; often quite striking. 

As another way of exploring CELLULAR, I suggest 
using FI to type In one of the rules from DEMO-2.DOC. 

Then, strike (del) for random initialization of the field 
of cells. You will see the screen much as I first saw it 
when this rule got odded to my list. Do this several 
times with each rule and note the difference between 
class 3 and class 4 In this mode. 
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These Programs will run on any PC or compatible that 
has a color graphics adapter, but the pictures will paint 
much faster on a PC-AT (which is what I am using). 

In closing I want to tell you of something that 
happened only yesterday (as I type this) and illustrates 
the sort of unexpected event that makes this game so 
interesting. I was giving this disk a final checkout 
before sending it off to Byte and running CELLULAR, not 
looking for anything in particular, when I happened on 
rule 0110223330. It belongs to a class that I call 
"wallpaper" which consist of structures of constant width 
that form vertical stripes all across the screen. These 
are usually rather uninteresting, but this rule is 
anything but that. I have never seen anything like it. 

I have added this rule to the end of DEMO-1.DOC. You 
might enjoy watching it on the screen as successive 
randon initializations are generated by pressing (Del). 


VIEWSET.C 

"Plotting the Mandelbrot Set." by Peter B. Schroeder. December, 1986, page 207. 


/***************************************************** 

* ViewSet.c (DISPLAYS MANDELBROT-SET) 

* by Peter B. Schroeder 12-10-85 (updated 1-29-86) 

* 11550 SW 108 Court Miami, FL 33176 (305)238-5509 

* Program opens data file specified in command line or 

* by default VIEW1.DATA; reads first three values from 

* data file (x-y coordinates and range), then reads in 

* and decodes display datum for each pixel; displays 

* data as a 200x200 low-resolution array; shows x-y 
coordinates and range; and, in all but last view, 
asks for keyboeard input to continue; after input, 
outlines area in next-smaller display, then waits 
for CLOSEWINDOW event from close-window gadget. 

By opening additional command-line interfaces, 
several of these displays may be run in parallel 


* several of these displays may De run in paramn. 
******************************************************/ 


^include <stdio.h> 

^include <exec/types.h> 

^include <ctype.h> 

^include <intuition/intuition.h> 

#include <1ibraries/transIator.h> 
linelude <devices/narrator.h> 

long Trans IatorBase; /* For translation */ 

UBYTE alIocationMap[]*{1,2,4.8}; /* Audio channels */ 
extern struct MsgPort *CreatePort(); /* For speech */ 

struct narrator^rb spk; /* F° r speech */ 

struct IntuitionBase *IntuitionBdse; 
struct GfxBase *GfxBase; 
struct NewScreen NewScreen = 


0. 

/* * 

0, 

/* 

320, 

/* 

200, 

/* 

4 , 

/* 

0. 1 » 

/* 

NULL, 

/* 

CUSTOMSCREEN, 

/* 

NULL, 

/* 


"Mandelbrot Screen", /* 
NULL, /* 
NULL, /* 

I: 


LeftEdge */ 
TopEdge */ 
Width (low resolution) */ 
Height */ 
Depth (16 colors) */ 
DetallPen and BlockPen */ 
No special display modes */ 
Screen type (not WorkBench) */ 
Use default font */ 
Compiled as a text pointer */ 
No special screen gadgets */ 
No special CustomBitMap */ 


main(argc.argv) int arge; char *argv[]; 

struct Screen *Screen; 
struct NewWindow NewWindow; 


[continued] 
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struct Window *Wlndow; 

struct RastPort *rp; 

struct Viewport *vp; 

struct View *v; 

struct IntuiMessage ^message; 

extern struct narrator_rb spk; 

l nt x,y,I,count,cI ass,rtncode,er ror; 

extern long TronsIatorBase; /* Must be external */ 

char fIle[15],axis[4][20],*sp,trs[250]; 

unsigned char a,b; /* Used for coding */ 

FILE *InFlie; 

/* Open file from command line or default */ 

lf(argc<«1) strcpy(f1 Ie,"VIEW1.DATA"); 
else strcpy(fIle,argv[lj); 

InFile » fopen(flIe,"r"); 
if(InFI Ie«*NULL) exit(TRUE); 

/* Read in coordinates and range */ 

for(x«0;x<3;x++) fgets(axis[x],20,InFile); 

/* Translate speech string */ 

sp « 

"Press any key to show area covered by next display."; 
Trans IatorBase-OpenLibrary("translator.Iibrary",0); 
rtncode*Translate(sp,strIen(sp),trs,250); 

/* Phonetic code now in string trs - CloseLibrary */ 

CIoseLibrary(Trans IatorBase); 
error=OpenDevice("narrator.device",0,&spk,0); 

/* Set up narrator message */ 

spk.message.io_Message.mn_RepIyPort » 

CreatePort("sayit",0); 
spk.ch_masks»aI IocationMap; /* All audio channels */ 
spk.nm_masks«4; /* Four of them */ 

spk.message.1o_Command*CMD_WRITE; /* What to do */ 
spk.message.io_Data=trs; /* What to verbalize */ 
spk.message.io_Length=strIen(trs); 

/* Open Intuition Library */ 

IntuitionBase - (struct IntuitionBase *) 

OpenLibrary("intuit ion.Iibrary",0); 
if(IntuitionBase NULL) exit(TRUE); 

/* Open Graphics Library */ 

GfxBase ■ 

(struct GfxBase *)OpenLibrary("graphics.I 1brary",0); 
If(GfxBase — NULL) exit(TRUE); 

/* Open Screen in Intuition */ 

1f((Screen - (struct Screen *)OpenScreen(&NewScreen)) 
== NULL) ex it(TRUE); 

/* Initialize new window structure */ 

NewWindow. LeftEdge = 0; 

NewWindow.TopEdge * 0; 

NewWindow.Width « 290; /* don’t cover screen width */ 
NewWindow.Height “200; 

NewWindow.DetaiIPen = 0; 

NewWindow.BlockPen = 1; 
if(index(fiIe,"WI")>=0) 


NewWindow.TitIe = "Mandelbrot View #1"; 
else NewWindow.TitIe = "Mandelbrot View"; 

NewWindow.FIags =WINDOWCLOSE|SMART_REFRESH|ACTIVATE| 
GIMMEZEROZERO|WINDOWDRAG|WINDOWDEPTH|WINDOWSIZINGj 
NOCAREREFRESH; /* See these flags in manual */ 
/* Need RAWKEY for INKEY type function */ 

/* Also need to know about CLOSEWINDOW events */ 

NewWindow.IDCMPFIags = RAWKEY|CLOSEWINDOW; 

NewWindow.Type = CUSTOMSCREEN; 

NewWindow.FirstGadget ■ NULL; /* No special gadget 


NewWindow.CheckMark * NULL; 
NewWindow.Screen * Screen; 
NewWindow.BitMap = NULL; 
NewWindow.MinWidth = 100 
NewWindow.MinHeight = 25 
NewWindow.MaxWidth = 320 
NewWindow.MaxHeight = 200; 
/* Open new window but end 
if((Window 


/* Don't need 
/* Use defauIt 


*/ 

*/ 

*/ 


*/ 


f can't have new one 

(struct Window *)0penWindow(&NewWindow)) 
— NULL) ex it(TRUE); 

/* Need the RastPort pointer from window structure */ 
(struct RastPort *)rp * Window->RPort; 

/* Also need ViewPort and View structure pointers */ 
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(struct Viewport *)vp « ViewPortAddress(Window); 
(struct View *)v « ViewAddress(); 

SetDrMd(rp,JAM1); /* Set draw mode to one pen 
/* Get count value from file and color each pixel 
for(y-1;y<200;y++) /* 

for(x-0;x<200;x++) /* 


Each row 
Each column or pixel 




a-getc(InF1 Ie 
b-getc(lnFiI 
count * a*255 + b; /* 

/* Select a color based 
** function and color each pixel accordingly 
SetAPen(rp,color(count)); /* Select a color 
WritePixel(rp,x,y); /* and color pixel 


/* Unsigned characters 
/* for coded numbers 
Decode count 
on counts using color 


*/ 

*/ 

*/ 

*/ 

*/ 

*/ 

*/ 

* 

*/ 

*/ 

*/ 


i 


} 


/* Close data file 
range of present display 
/* Text in white 


fclose(InFlle); 

/* Show coordinates and 
SetAPen(rp.l); 

Move(rp,210,30); 

Text(rp," x =",4); 

Move(rp,201,40); 

Text(rp,axis[0J,9); 

Move(rp,210,55); 

Text(rp," y =",4); 

Move(rp,201,65); 

Text(rp,axis[11,9); 

Move(rp.210,80); 

Text(rp,"range *",7); 

Move(rp,201,90); 

Text(rp,axis[2J,9); 

/* Determine coordinates of next 
1-0; if(index(fiIe,"W1")>«0) 
x-80; y-108;1-1; $ 
else 1f(Index(flie,"W2")>*0) 
x-150;y-64; 1-1; \ 
else if(index(flie,"W3")>*0) 

{ x-170;y-1; 1-1; J 

else if(1ndex(file,"W4")>«0) 
j x-140;y«100;1-1; \ 
if(I>0) 

DoIO(fcspk); /* speak and wa 
Wait(1«Window->UserPort->mp_SigBit); 

/* Draw box showing next smaller display, if any 
Move(rp.x.y); 
x +» 20; 

Draw(rp,x,y); 
y +- 20; 

Draw(rp.x.y); 
x — 20; 

Draw(rp,x,y); 
y — 20; 

Draw(rp,x,y); 


*/ 

*/ 

*/ 


t-sma11er 

display 

*/ 

/• 

First 

view 

*/ 

/* 

Second 

1 vi ew 

*/ 

/* 

Third 

view 

*/ 

/* 

Fourth 

i view 

*/ 

for 

any key pressed 

*/ 


*/ 


/* Wait here for CLOSEWINDOW event, ignore RAWKEY */ 
eye Ie: 

Wait(1«Window->UserPort->mp„SigB11); /*Wait input*/ 
message = GetMsg(Window->UserPort); /* Get it */ 

class - message->CI ass; /* What is it */ 

if(class—RAWKEY) goto cycle; /* Ignore RAWKEY */ 
/* If CLOSEWINDOW event then end program */ 

DeletePort(spk.message.io_Message.mn_RepIyPort); 
CloseDevice(&8pk); 

CloseWindowfWindowl; 

CIoseScreen(Screen); 

CloseLibrary(GfxBase); 

CloseLibrary(lntultionBase); 
ex it(TRUE); 

} /*end main*/ 


/* Function index from Kernighan and Ritchie p.68 */ 

lndex(s,t) char s[],t[]; 

I 


(i continued ) 
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Int I.J.k; 

for(l-0;s[l]!- , \0‘;l++) 

for (J-l ,k-0; t[k] !-*\0' klc s[J]« t[k] ; J++,k++); 

I f (t[k]—'\0* ; return(i); 

return(-1); 

( /* End function Index */ 

/* Function color (assigns color to counts). * 

** Input: integer count. Output integer nc (color) * 
** This code can be modified to give the desired * 


** colors for different counts 
int color(count) int count; 


int nc; 

I f(count>995) nc«9; 


e 1 se 

If! 

(count>400) 

) nc 

s 

1 

e 1 se 

if! 

l count>350' 

) nc 

s 

10 

e 1 se 

if! 

[count>300] 

) nc 

a 

4 

e 1 se 

if! 

fcount>250' 

) nc 

a 

3 

e 1 se 

if! 

(count>200. 

) nc 

a 

8 

e 1 se 

if! 

fcount>150] 

) nc 

a 

11 

e 1 se 

if! 

[count>100] 

) nc 

a 

13 

e 1 se 

if! 

fcount> 90' 

) nc 

a 

6 

e 1 se 

if! 

^count> 80, 

) nc 

a 

15 

e 1 se 

If! 

(count> 70' 

) nc 

a 

5 

e 1 se 

If! 

[count> 60, 

) nc 

a 

2 

e 1 se 

if! 

Jcount> 50' 

) nc 

a 

7 

e 1 se 

if! 

count> 45, 

1 nc 

a 

12 

e 1 se 

If! 

Jcount> 40} 

1 nc 

a 

0 

e 1 se 

If! 

Jcount> 35j 

1 nc 

a 

15 

e 1 se 

if! 

Jcount> 30} 

\ nc 

a 

3 

e 1 se 

if! 

[count> 20j 

1 nc 

a 

11 

e 1 se 

if! 

[count> 10) 

l nc 

a 

4 

e 1 se 

nc 

= 14; 





if(nc «« 4 kk count % 2 *== 
1f(nc ■■ 14 kk count % 2 == 
return(nc); 

} /*End function color */ 


id ranges of counts. 

*/ 

/* 

2 

a 

black 

*/ 

/* 

3 

a 

orange 

*/ 

/* 

4 

a 

bright blue 

*/ 

/* 

5 

a 

violet 

*/ 

/* 

6 

a 

sky blue 

*/ 

/* 

7 

a 

white 

*/ 

/* 

8 

a 

brown 

*/ 

/* 

9 

a 

red 

*/ 

/* 

10 

a 

green 

*/ 

/* 

11 

a 

ye 1 low 

*/ 

/* 12 

a 

bright blue 

*/ 

/* 

13 

a 

grey blue 

*/ 

/* 

14 

a 

green 

*/ 

/* 

15 

a 

grey 

*/ 


0) nc * 8; 
0) nc * 8; 


DOSET.C 

"Plotting the Mandelbrot Set," by Peter B Schroeder, December, 1986, page 207. 


/***************************************************** 

* DoSet.c (CALCULATES MANDELBRO-SET) 

* by Peter B. Schroeder 12-10-85 (updated 1-29-86) 

* 11550 SW 108 Court Miami, FL 33176 (305)238-5509 

* Program asks for coordinates (lower left-hand corner) 

* and range of display. It then opens for output a data 

* file specified in the command line or, by default, 

* called ZOOM.DATA; writes the coordinates and range to 

* the file; then multiples the complex number based on 

* the x,y values of a 200x200 pixel array for 1,000 

* iterations or until the sum of the squares of two 

* parts of the complex number reach or exceed four. The 

* count-of-iterations for each pixel (a number from 

* 1 to 1,000) are coded into two bytes and these values 

* are written to the data file row by row for display 

* by the ViewSet program. 

ft*****************************************************/ 

#include <stdio.h> 

#include <math.h> 


main(argc,argv) int argcjchar *argv[]; 
int y,x,count,totct; 

fI oat x_coord,y_coord,range,gap,sIze,a,b,ac,be,bl; 
char ct[201][2]; 

FILE *OutFile; 

/* Input x-y coordinates and range from keyboard */ 
printf("Input X.COORDINATE: "); 
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scant("%f",&x_coord); 
printfCInput Y_COORDINATE: "); 
scant("%f",&y_coord); 
print?("Input RANGE: "); 

scant("%t",Grange); 

gap « range / 200.0; /* Increment per pixel */ 

y_coord +« range; /* Start at top ot display */ 

/* Open output tile (detault or command line) */ 

if(argc<=1) OutFile = fopen("df1:ZOOM.DATA","w"); 
else OutFile = fopen(argv[1],"w"); 

/* Write coordinates and range to data tile */ 

fprintf(OutFile,"%7.6t\n",x_coordh 
tprintf(OutFiIe,"%7.6t\n",y_coord); 
tprintf(OutFiIe,"%8.7t\n",range); 

/* Calculate count value tor each pixel (200X200) */ 

for(y=1;y<«200;y++) /* Each row */ 

be * y_coord - y*gap; totet « 0; 

tor(x*1;x<*200;x++) /* Each pixel per row */ 

ac * x*gap + x_coord; 
a * ac; b * be; size = 0.0; count = 0; 
while(size < 4.0 kk count < 1000) 

/* Do complex-number multiply */ 

bl * 2*a*b; 
a « a*a — b*b + ac; 
b « bl + be; 

/* Pythagorean theorem */ 

size * a*a + b*b; 

/* Don't need square root */ 

count++; 


totet +« count; 

/* Code count in two bytes to save disk space 
ct[xl[0l - count/256; 
ct[x][1J ■ count % 256; 

} /* End x loop 

/* Show row number and average count to CRT 
prlntf("%5d X5d\n M ,y.totct/200); 

/* Print coded pixel-values this row to data file 
for(x»1;x<«200;x++) 

putc(ct[x][0],OutFile); 
putc(ct[x][1J,OutFile); 

I 

| /* End y loop 

fclose(OutFIle); /* Close data file 
J /* End main 


*/ 

*/ 

*/ 

*/ 


*/ 

*/ 

*/ 


QUADRIC1.BAS 

"Graphing Quadric Surfaces," by George Haroney, December. 1986, page 215. 


10 SCREEN 1 :REM 320 H by 200 V, 3 colors 

20 DEFINT H-N 
30 PI-4*ATN(1) 

40 DR=PI/180 :REM Converts degrees to radians 
50 BLUE-1: PURPLE-2: WHITE-3 
60 HMIN-0: HMAX-319 
70 LMIN-0: LMAX-199 
80 HRES-HMAX-HMIN: LRES-LMAX-LMIN 

90 REM -Define function and set parameters - 

100 DEF FNF1(X,Y)-X*X+YeY :REM Paroboloid 

110 HC-HMIN+INT(HRES/2) 

120 LC-LMIN+INT(19-LRES/20) 

130 SCALEH-12 
140 SCALEV-2 

150 REM -Find Angles from center to corners - 

160 C1-ATN((LC-LMIN)/(HMAX-HC)) :REM to NE 

170 C 2 -PI-ATN((LC-LMIN)/fHC-HMIN)) :REM to NW 

180 C 3 -PI+ATN((LMAX-LC)/(HC-HMIN)) :REM to S» 
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190 C4*2*PI-ATN((LMAX-LC)/(HMAX-HC)) :REM to SE 

200 REM-X Y Z oxe*- 

210 KOLOR-WHITE 

220 INPUT "Angles for x.y.z oxes «; DEGX.DEGY,DEGZ 
2« DEGREES-DEGX 

250 GOSUB 1080 :REM Convert degrees to radians A 
260 SINXA-SIN(A): COSXA-COS(A) 

270 REM GOSUB 1010: REM Draw the oxis 
280 DEGREES-DEGY 
290 GOSUB 1080 

300 SINYA-SIN(A): COSYA-COS(A) 

310 REM GOSUB 1010 
320 DEGREES-DEGZ 
330 GOSUB 1080 

340 SINZA-SIN(A): COSZA-COS(A) 


350 REM GOSUB 1010 

360 REM-Plot the surface- 

370 FOR TY—6 TO 6 STEP .4 

380 KOLOR-PURPLE :REM To show points s.t. x>-0 

420 FOR TX-0 TO 6 STEP .4 
430 TZ«FNF1(TX,TY) 

440 GOSUB 1230 :REM Project and scale 

450 PSET (MH,MV),KOLOR 
460 NEXT TX 

470 KOLOR-BLUE :REM To show points s.t. x<0 

510 FOR TX—6 TO 0 STEP .15 
520 TZ-FNFI(TX.TY) 

530 GOSUB 1230 :REM Project and scale 

540 PSET (MH,MV),KOLOR 


550 NEXT TX,TY :REM Next point on current tracing 
560 END 
1000 
1010 
1020 
1030 
1040 
1050 
1060 
1070 
1080 
1090 
1100 
1110 
1120 
1130 
1140 
1150 
1160 
1170 
1180 
1190 
1200 
1210 
1220 
1230 
1240 
1250 
1260 
1270 


line through center to borders - 

:REM Save tangent 
:REM Get one endpoint 
1080: 

:REM Other endpoint 


REM-Extend 

TANA-TAN(A) 

GOSUB 1170: HI-HZ: L1-LZ 
DEGREES-DEGREES+180: GOSUB 
GOSUB 1170: H2-HZ: L2-LZ 
LINE (H1,L1)-(H2,L2),KOLOR 
RETURN 

REM — Converts degrees to radians, 0 <- a < 2*pl - 

WHILE DEGREES<0 

DEGREES-DEGREES+360 

WEND 

WHILE DEGREES>«360 

DEGREES-DEGREES-360 

WEND 

A-DEGREES*DR 

RETURN 

REM Find endpoint (hz.lz) of ray at (hc,lc), angle a 
IF A<«C1 OR A>C4 THEN HZ-HMAX: LZ«LC-(HMAX-HC)*TANA: RETURN 
IF A<-C2 THEN LZ-LMIN: HZ»HC+(LC-LMIN)/TANA: 


LZ-LC+(HC-HMIN)*TANA: 
HZ-HC-(LMAX-LC)/TANA 


IF A<=C3 THEN HZ-HMIN 
IF A<-C4 THEN LZ-LMAX 
RETURN 

REM-Project tx.ty.tz onto mh,mv 

PX»TX*COSXA+TY*COSYA+TZ*COSZA 
PY«TX*SINXA+TY*SINYA+TZ*SINZA 
MH«INT(HC+PX*SCALEH) 

MV-INT(LC-PY*SCALEV) 

RETURN 


RETURN 

RETURN 


QUADRIC2.BAS 

“Graphing Quadric Surfaces," by George Haroney, December, 1986, page 215. 


1 REM MERGE THIS PROGRAM INTO QUADRIC1.BAS 

100 DEF FNF1(X,Y)«Y*Y-X*X :REM Hyperbolic paraboloid 

110 HC-HMIN+INT(HRES/2) 

120 LC=LMIN+INT(LRES/2) 

130 SCALEH-15 

140 SCALEV-3.5 

370 FOR TY—5 TO 5 STEP .4 

380 KOLOR-PURPLE 
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390 FOR TX-0 TO 5 STEP .4 
400 TZ-FNF1(TX.TY) 

410 GOSUB 1230 

420 PSET (MH.MV),KOLOR 

430 NEXT TX 

440 KOLOR-BLUE :REM To 

450 FOR TX—5 TO 0 STEP .1 
460 TZ-FNF1(TX.TY) 

470 GOSUB 1230 
480 PSET (MH.MV),KOLOR 
490 NEXT TX.TY 
500 END 


:REM Project ond scole 

•how point8 s.t. x<0 

:REM Project and scale 
:REM Plot o point 


QUADRIC3.8AS 

"Graphing Quadric Surfaces," by George Haroney, December, 1986, page 215. 


1 REM MERGE THIS PROGRAM INTO QUADRIC1.BAS 
100 DEF FNF1(X,Y)-SQR(Y*Y+X*X)*2 :REM Cone 
110 HC-HMIN+INT(HRES/2) 

120 LC-LMIN+INT(LRES/2) 

130 SCALEH-8 
140 SCALEV-4 

370 FOR TY—6 TO 6 STEP .75 
380 KOLOR-PURPLE 
390 FOR TX-0 TO 6 STEP .5 
400 TZ-FNF1(TX.TY) 

410 GOSUB 1230 :REM Project and scale 

420 PSET (MH.MV),KOLOR :REM Plot a point 
430 TZ—FNFI(TX.TY) 

440 GOSUB 1230 

450 PSET (MH.MV),KOLOR 

460 NEXT TX 

470 KOLOR-BLUE 

480 FOR TX—6 TO 0 STEP .2 

490 TZ-FNF1(TX.TY) 

500 GOSUB 1230 

510 PSET (MH.MV),KOLOR 

520 TZ—FNF1 (TX.TY) 

530 GOSUB 1230 
540 PSET (MH.MV),KOLOR 
550 NEXT TX.TY 
560 END 


QUADRIC4.BAS 

"Grophing Quadric Surfaces," by George Haroney, December, 1986, page 215. 


1 REM MERGE THIS PROGRAM INTO QUADRIC1.BAS 

100 DEF FNF1 (X,Y)-SQR(Y*Y+X*X-2)*2 :REM HB of 1 sheet 

110 HC-HMIN+INT(HRES/2) 

120 LC-LMIN+INT(LRES/2) 

130 SCALEH-8 
140 SCALEV-7 

370 FOR TY—4 TO 4 STEP .5 
380 FOR TX—4 TO 4 STEP .2 

390 IF TX*TX+TY*TY<2 THEN 460 ELSE TZ-FNF1(TX.TY) 

400 GOSUB 1230 :REM Project and scale 

410 IF TX<0 THEN KOLOR-BLUE ELSE KOLOR-PURPLE 

420 PSET (MH.MV),KOLOR :REM Plot a point 

430 TZ—TZ 

440 GOSUB 1230 

450 PSET (MH.MV),KOLOR 

460 NEXT TX.TY 

470 END 
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QUADRIC5.BAS 

"Graphing Quadric Surfaces," by George Haroney, December, 1986, page 215. 


1 REM MERGE THIS PROGRAM INTO QUADRIC1.BAS 

100 DEF FNF1(X,Y)«SQR(Y*Y-X*X-1) :REM HB of 2 sheets 

110 HC-HMIN+INT(HRES/2) 

120 LC-LMIN+INT(LRES/2) 

130 SCALEH-3 
140 SCALEV-3 

370 FOR TY—20 TO 20 STEP 2 
380 FOR TX—20 TO 20 STEP .3 

390 IF TX*TX+1>TY*TY THEN 460 ELSE TZ-FNF1(TX.TY) 

400 GOSUB 1230 :REM Project and scale 

410 IF TX<0 THEN KOLOR=BLUE ELSE KOLOR-PURPLE 

420 PSET (MH,MV),KOLOR :REM Plot a point 

430 TZ—TZ 

440 GOSUB 1230 

450 PSET (MH,MV),KOLOR 

460 NEXT TX,TY 

470 END 


QUADRIC6.BAS 

"Graphing Quadric Surfaces," by George Haroney, December, 1986, page 215. 


1 REM MERGE THIS PROGRAM INTO QUADRIC1.BAS 
100 DEF FNF1(X,Y)*SQR(1-X*X-Y*Y) :REM Ellipsoid 
110 HC=HMIN+INT(HRES/2) 

120 LC-LMIN+INT(LRES/2) 

130 SCALEH-50 
140 SCALEV-50 

370 FOR TY—.99 TO 1 STEP .15 

380 KOLOR=PURPLE 

390 FOR TX-.01 TO 1 STEP .03 

400 IF TX*TX+TY*TY>»1 THEN 460 ELSE TZ-FNF1(TX,TY) 

410 GOSUB 1230 :REM Project and scale 

420 PSET (MH,MV),KOLOR :REM Plot a point 

430 TZ—TZ 

440 GOSUB 1230 :REM Project and scale 

450 PSET (MH,MV),KOLOR :REM Plot a point 

460 NEXT TX 

470 KOLOR-BLUE 

480 FOR TX—1 TO 0 STEP .015 

490 IF TX*TX+TY*TY>®1 THEN 550 ELSE TZ-FNF1(TX,TY) 

500 GOSUB 1230 

510 PSET (MH,MV),KOLOR 

520 TZ*-TZ 

530 GOSUB 1230 

540 PSET (MH,MV),KOLOR 

550 NEXT TX.TY 

560 END 


BEZIER2.SUB 

"Free-Form Curves On Your Micro," by Steve Enns, December 1986, page 225. 


16960 * Bezier2.SUB 

16962 • From Fundamentals of Interactive Computer Graphics 
16964 • 

16966 * Calculates cubic parametric freeform Bezier curves 
16968 • XBS23-1 for 3d else 2d 

16970 • XBZDR-0 is the curve is to be drawn (2d only) 

16972 ' XC(),YC(),[ ZC() ] are the hull points (4 per curve) 
16974 • XNC is the index of first control point 
16976 * XNB is the number of control points to be used 
16978 ' XNP is the index for the first curve point 
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16980 ' NBS is the step size (defoult provided) 

16982 * QBZ is the color if drown 

16984 ’ Returns X(),Y(),[ Z() ] os the points 

16986 * Returns XNS os the index of the lost curve point 

16988 * 

16990 IS-XNP:XXS-XNC+XNB-1 
16992 IF NBS-0 THEN NBS-.1 
16994 IF XBS23 THEN 17016 
16996 FOR IIS-XNC TO XXS STEP 4 
16998 FOR T-0 TO 1+N8S STEP NBS 
17000 T2-T*T:T3»T2*T 

17002 NO1-1-3*T+3*T2-T3:NC2«3*T3-6*T2+3*T:NC3 

-3*T2-3*T3:NC4-T3 

17004 X(I$)-NC1*XC(IIS)+NC2*XC(IIS+1)+NC3*XC(IIS+2) 

+NC4*XC(IIS+3) 

17006 Y(IS)«NC1*YC(II$)+NC2*YC(IIS+1)+NC3*YC(IIS+2) 

+NC4*YC(IIS+3) 

17008 IS-IS+1 

17010 NEXT 

17012 NEXT 

17014 GOTO 17036 

17016 FOR IIS-XNC TO XXS STEP 4 

17018 FOR T-0 TO 1+NBS STEP NBS 

17020 T2-T*T:T3-T2*T 

17022 NC1-1-3*T+3*T2-T3:NC2-3*T3-6*T2+3*T:NC3-3+T2 

-3*T3:NC4-T3 

17024 X(IS)-NC1*XC(IIS)+NC2*XC(IIS+1)+NC3*XC(IIS+2) 

+NC4*XC(IIS+3) 

17026 Y(IS)-NC1*YC(IIS)+NC2*YC(IIS+1)+NC3*YC(IIS+2) 

+NC4*YC(IIS+3) 

17028 Z(IS)-NC1*ZC(IIS)+NC2*ZC(IIS+1)+NC3*ZC(IIS+2) 

+NC4*ZC(IIS+3) 

17030 IS-IS+1 

17032 NEXT 

17034 NEXT 
17036 XNS-IS-1 
17038 IF XBZDR THEN 17048 
17040 PSET(X(XNP),Y(XNP)),QBZ 
17042 FOR II-XNP TO XNP+XNS 
17044 LINE -(X(II),Y(II)),QBZ 

17046 NEXT 
17048 RETURN 


* Pixel at x,y color QBZ 

* Line from last X,Y to 

* XI,Y1 color QBZ 


BSPLINE.SUB 

"Free-Form Curves On Your Micro,” by Steve Enn9, December 1986, page 225. 


16850 1 BSpline.SUB 

16852 * From Fundamentals of Interactive Computer Graphics 
16854 # 

16856 • Calculates cubic parametric free-form splines 

16858 * XBS23-1 for 3d else 2d 

16860 * XBSDR-0 if the curve is to be drawn 

16862 * XC(),YC(),[ ZC() ] are the control points 

16864 * XNC is the index of first control point 

16866 * XNB is the number of control points to be used 

16868 * XNP is the index for the first spline point 

16870 • NBS is the step size 

16872 * QBS is the color If drawn 

16874 * Returns X(),Y(),[ Z() ] as the points 

16876 * Returns XNS as the index of the last spline point 

16878 * 

16880 IS-XNP:XXS-XNC+XNB-3:NSA-1/6:NSB-2/3 
16882 IF XBS23 THEN 16904 
16884 FOR IIS-XNC+1 TO XXS 
16886 FOR T-0 TO 1 STEP NBS 

16888 T1 -T/2: T2-T*T: T2A-T2/2: T3-T2*T: T3A-T3/2 

16890 NC1—NSA*T3+T2A-T1+NSA:NC2-T3A-T2+NSB:NC3 

—T3A+T2A+T1+NSA:NC4«NSA*T3 

16892 X(IS)-NC1*XC(IIS-1)+NC2*XC(IIS)+NC3*XC(IIS+1) 

+NC4*XC(IIS+2) 
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16894 Y(IS)-NC1*YC(IIS-1)+NC2*YC(IIS)+NC3*YC(IIS+1) 

+NC4*YC(IIS+2) 

16896 IS-IS+1 

16898 NEXT 

16900 NEXT 

16902 GOTO 16924 

16904 FOR IIS-XNC+1 TO XXS 

16906 FOR T-0 TO 1 STEP NBS 

16908 T1«.5*T:T2-T*T:T2A-.5*T2:T3-T2+T:T3A-T3/2 

16910 NCI—NSA*T3+T2A-T1+NSA:NC2-T3A-T2+NSB:NC3—T3A 

+T2A+T1+NSA:NC4-NSA*T3 

16912 X(IS)«NC1*XC(IIS-1)+NC2*XC(IIS)+NC3*XC(IIS+1) 

+NC4*XC(IIS+2) 

16914 Y(IS)-NC1*YC(IIS-1)+NC2*YC(IIS)+NC3*YC(IIS+1) 

+NC4*YC(IIS+2) 

16916 Z(IS)-NC1*ZC(IIS-1)+NC2*ZC(IIS)+NC3*ZC(IIS+1) 

+NC4*ZC(IIS+2) 

16918 IS-IS+1 

16920 NEXT 

16922 NEXT 
16924 XNS-IS 

16926 IF XBSDR THEN 16936 

16928 PSET(X(XNP),Y(XNP)),QBS * Set pixel, x,y color QBS 
16930 FOR II-XNP TO XNP+XNS-1 

16932 LINE -(X(II),Y(II)),QBS • Line from lost X,Y to 

16934 NEXT • X1.Y1 color QBS 

16936 RETURN 


CURVTEST.BAS 

"Free-Form Curves On Your Micro," by Steve Enns, December 1986, page 225. 


1 • 
2 1 

3 1 

4 • 

5 1 
10 
11 
12 

13 

14 

15 


ivvvvvvvvvvvvvv\vvvvvvvvvvvvvvvvvvvvvvvvv\vvvvvvvwvvvvvvvvvvvvvvv[ 
V CurvTest V 0277 Lines V Steve Enns Feb.21 1985 7 
7 Version 1.1 7 11136 Bytes 7 Com. Feb.21 1985 7 
Qvvvvvvvvvvvvvvkvvvvvvvvvvvvvvvvvvvvvvvvvkvvvvvvvvvvvvvvvvvvvvvvvv) 


Entry 


Versions of BASIC for PC’s other then the TI PC will likely require 
that this program initialize the graphics screen. The resolution 
of the graphics screen is given in lines 70 and 80. Line 80 contains 
the maximum x and y coordinates. The fourth place in a COLOR state- 


16 *- ment is the character attribute, (flashing, reverse video, etc.) 


Lines 4030 to 4050 draw and store a cross-hair cursor. Different 
screen resolutions may require a larger or smaller cursor. GSX and 
GSY determine how far the cursor will move on a shifted-arrow key. 
Both graphics and text on the same screen are required. 


Initialize storage and variables 


17 

18 

19 

20 

29 

30 
40 

50 DEFINT X,Y 

60 DIM XC(300),YC(300),X(5000),Y(5000) 
70 XVI-0:YVI-0 
80 X1VI-719:Y1VI-299 
90 GSX-30:GSY-20 
100 GRIDIS-1 
1-1 

NBS-.05 
QBS-2:QBZ-4 


Clear the screen 


CLSiKEY OFF:COLOR 3,,,0:LOCATE ,,0 


110 
120 
130 
140 
150 
160 
170 
180 ’ 

190 '-Initialize function keys 

200 • 


220 

230 

240 

250 

252 


Ctrl and curve points 
Upper left of Gr. screen 
Lower Right of Gr. screen 
See GRCURSOR.SUB 
See GRCURSOR.SUB 
Count of Ctrl points 
Increment (Curv.SUB’s) 
Colors for curves 


KEY 1,"POINT ":ON KEY(1 ) 

1 GOSUB 600:KEY( 

[I] 

1 ON 

KEY 2,"SPLINE":0N KEYI 

[2] 

) GOSUB 770:KEYI 

[2] 

1 ON 

KEY 3,"BEZIER":0N KEYI 

3 

1 GOSUB 850:KEYI 

3 

1 ON 

KEY 4,"EPOINT":0N KEY! 


) GOSUB 690:KEYI 

;4j 

1 ON 

KEY 5,"ERASE ":0N KEYI 

5 

) GOSUB 940:KEYI 

5 

) ON 

KEY 6,"EXIT ":0N KEY(6] 

) G0SU8 996:KEY(6] 

) ON 
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260 • 

270 KEY ON 

280 LOCATE 25,48:PRINT STRING$(32,32) 

281 ‘ 

282 ’-Title- 

283 ’ 

290 COLOR 7,,,0:LOCATE 1,1 

291 PRINT" IVVVVVVVVVVi" 

293 PRINT"V CURVTEST 7" 

294 PRiNT"0wwwiw»O" 


297 ' 

298 •-Main program- 

299 * 

300 GOSUB 4040 '-Init. (GRCURSOR.SUB) 

310 GOSUB 3852 *- Enter crosshair loop 

320 • 

330 *- Application specific subroutines - 

340 * 

350 *- Update cursor coordinates - 

360 • 


370 COLOR 7, ,,0:LOCATE 25,50 

372 PRINT"Cursor: x=";XPOS; M y«";YPOS; 

380 RETURN 
450 * 

460 *- Erase message - 

470 • 

480 COLOR 3,,,0:LOCATE 23,70 
490 PRINT" 

500 RETURN 
510 • 

520 *- Initialize control points for curves - 

530 ' 

540 XNC*1:XNB«I-1:12-1:1-1 ’- Init. Ctrl point position 

542 COLOR 7,,,16+64:LOCATE 23,70 

544 PRINT"WORKING"; ’- Print working message 

550 RETURN 


560 ' 

570 *- Function key interrupt vectors 

580 * 

590 »- Get control points - (POINT) ~ 

600 ' 


610 XC(I)«XPOS:YC(I)«YPOS 
620 GOSUB 3930 

630 PSET(XC(I),YC(I)),7 ’- Set pixel (xc(i),yc(i)), 

640 GOSUB 3930 'with color 7 

650 I-I+1 
660 RETURN 
670 • 

680 *- Erase control points - (EPOINT) - 

690 * 

700 FOR IC-1 TO 12 

710 IF POINT(XC(IC),YC(IC))=QBS OR POINT(XC(IC),YC(IC))*QBZ THEN 730 
720 PSET(XC(IC),YC(IC)),0 *- Check for pixels, else 


730 NEXT 'erase the pixel, color 0 

740 RETURN 
750 ' 

760 '-Put B-spline - (SPLINE)- 

770 ' 

780 GOSUB 540 *- Init. curve Ctrl points 

800 GOSUB 16880 *- Calc, and draw spline 

810 GOSUB 480 *- Erase message 

820 RETURN 
830 ' 

840 •-Put Bezier curve - (BEZIER)- 

850 ' 

860 GOSUB 540 *- Init. curve Ctrl poi-ts 

880 GOSUB 16990 *- Calc, and draw 9ez. c.'-e 

890 GOSUB 480 *- Erase message 

900 RETURN 
910 ' 

920 '-Clear screen - (CLEAR)- 

930 ' 

940 GOSUB 3930 

950 CLS 1 *-Clear graphic o-c te*t 

970 GOSUB 3930 


(continued) 
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980 GOSUB 370 
990 RETURN 

992 • 

993 *- Leave program - (EXIT) - 

994 ’ 

996 GOSUB 9821 *- Replace key definitions 

997 COLOR 3,,,0:CLS 

998 END 
1000 * 

1010 *- General subroutines - 

1020 * 

3780 ’ Grcursor.SUB (Altered) Steve Enns Dec.26 1983 

3790 * 

3800 ' Calling program must execute a GOSUB 4040 to inlt. cursor 

3810 ’ Clears screen area descibed below 

3820 • XVI,YVI,X1VI,Y1VI Is the viewport 

3830 ’ GRIDIS Is 1 for no grid displayed 

3840 ’ GSX.GSY are the grid increments 

3850 ’ 


3852 GOSUB 4000 
3854 GOSUB 4872 
3858 IF GRIDIS THEN 3870 

3860 X-XVI:Y-YVI:X1-X1VI:Y1-Y1VI:XS=GSX:YS-GSY:Q-1 

3861 GOSUB 8340 

3870 XCEN-XVI+.5*(X1VI-XVI):YCEN-YVI+.5*(Y1VI-YVI) 

3871 XPOS-XCEN:YPOS-YCEN 

3872 GOSUB 3950 

3879 Q9$=INKEY$ 

3880 IF Q9$«"" THEN 3879 

3882 GOSUB 3930 

3883 IF Q9$«LQ$ THEN XPOS-XPOS-1:GOTO 3950 

3884 IF Q9$=RQ$ THEN XPOS-XPOS+1:GOTO 3950 

3885 IF Q9$=DQ$ THEN YPOS-YPOS+1:GOTO 3950 

3886 IF Q9$-UQ$ THEN YPOS-YPOS-1:GOTO 3950 
3888 IF Q9$=HQ$ THEN M0DE$="set":GOTO 3950 
3890 IF Q9$=SRQ$ THEN XPOS«XPOS+GSX:GOTO 3950 
3892 IF Q9$-SLQ$ THEN XPOS-XPOS-GSX:GOTO 3950 
3894 IF Q9$=SDQ$ THEN YPOS-YPOS+GSY:GOTO 3950 
3896 IF Q9$-SUQ$ THEN YPOS-YPOS-GSY:GOTO 3950 

3900 IF Q9$»SHQ$ THEN XPOS-XCEN:YPOS-YCEN:GOTO 3950 ELSE 3950 
3920 * Erase cursor 

3930 PUT(XC.YC),CUR ’- Put image CUR at XC.YC 

3932 RETURN 

3940 • Put cursor 

3950 GOSUB 3970 

3951 GOSUB 370 

3952 XC*XPOS-15:YC=YPOS-9 

3953 PUT (XC.YC),CUR *- Put image CUR at XC.YC 

3954 GOTO 3879 

3960 * Check values 

3970 IF XP0S<XVI+15 THEN XP0S=XVI+15:BEEP 

3971 IF XPOS>X1VI-15 THEN XP0S»X1VI-15:BEEP 

3980 IF YPOS<YVI+9 THEN YP0S=YVI+9:BEEP 

3981 IF YP0S>Y1VI-8 THEN YP0S»Y1VI-8:BEEP 
3990 RETURN 

4000 IF XVI<0 THEN XVI=0 ELSE IF XVI>719 THEN XVI=719 
4010 IF YVI<0 THEN YVI=0 ELSE IF YVI>299 THEN YVI=299 
4020 RETURN 

4030 ’ Draw and get cursor 

4040 DEFINT C:DIM CTEMP(110),CUR(110) 

4041 GET (0,0)-(29,17).CTEMP 

4042 LINE (0,0)-(29,17),0,BF ’- Define the cursor 

4043 LINE (0,9)-(8.9),6:LINE (21,9)-(29,9),6 ’- lines (x.y) to (xl.yl) 

4044 LINE (15,0)-(15,4),7:LINE (15,13)-(15,17),7 

4045 PSET(15,9),7 

4046 GET (0,0)-(29,17),CUR '- Store Image In array CUR 

4047 LINE (0,0)-(29,17),0,BF 

4048 PUT(0.0),CTEMP 

4049 ERASE CTEMP ’-Erase the array CTEMP 

4050 RETURN 

4820 * Arowinlt.SUB Steve Enns Dec.18 1983 

4830 * 

4840 ’ Initializes arrow keys for trapping 

4850 ’ Returns LQ$,RQ$.UQ$,DQ$,HQ$ as the arrow keys on return 

4860 ’ Returns SLQ$,SRQ$,SUQ$,SDQ$,SHQ$ as the shifted arrow keys 

4870 ’ 
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0)+"M" 

0)+"P" 


4872 LQ$»CHR$(0)+"K”:RQ$=CHR$(0 
4874 UQ$-CHR$(0)+"H”:DQ$-CHR$(‘ 

4876 HQ$-CHR$(0) + "G" : SRQ$-CHR$(0) + "£" 

4878 SLQ$«CHR$(0)+"f":SUQ$»CHR$(0)+"H" 

4879 SDQ$»CHR$(0)+"t”:SHQ$«CHR$( 0 )+" o " 

4880 RETURN 
9810 ’ Baskeys.SUB 
9812 ’ 

9815 * Initializes keys to BASIC defaults 

9820 ’ 

9821 KEY 1,CHR$(27)+"LIST " 

9822 KEY 2,CHR$(27)+"RUN ,, +CHR$(13) 

9823 KEY 3, ,, L0AD"+CHR$(34) 

9824 KEY 4,"SAVE"+CHR$(34) 

9825 KEY 5.CHR$(27)+"FILES"+CHR$(13) 

9826 KEY 6,CHR$(27)+"C0NT"+CHR$(13) 

9827 KEY 7,".SUB" 

9828 KEY 8,".UTL" 

9829 KEY 9,CHR$(27)+"C0L0R 3,0.0.0"+CHR$(13) 

9830 KEY 10,CHR$(27)+"PALETTE"+CHR$(13) 

9840 RETURN 
16850 * BSpline.SUB 


Steve Enns Dec. 30 1983 


Steve Enns Dec.20 1984 


16852 ’ 

From Fund, of Int 

16854 * 



16856 • 

Calculates cubic parametric free-form 

sp1ines 

16858 * 

XBS23-1 for 3d else 2d 


16860 * 

XBSDR-0 if the curve is to be drawn 


16862 • 

XC(),YC(),[ ZC() ] are the control po 

ints 

16864 ■ 

XNC is the index of first control point 

16866 • 

XNB is the number of control points to be used 

16868 * 

XNP is the index for the first spline 

point 

16870 • 

NBS is the step size 


16872 • 

QBS is the color if drawn 


16874 ■ 

Returns X().Y(),[ Z() ] as the points 


16876 * 

Returns XNS as the index of the last 

sp1ine point 

16878 ’ 




p .521 


16880 IS=XNP:XXS-XNC+XNB-3:NSA-1/6:NSB*2/3 
16882 IF XBS23 THEN 16904 
16884 FOR IIS-XNC+1 TO XXS 


16886 

16888 

16890 

16892 

16894 

16896 

16898 


FOR T=0 TO 1 STEP NBS 

T1-T/2:T2-T*T:T2A-T2/2:T3-T2*T:T3A=T3/2 

NC1=-NSA*T3+T2A-T1+NSA:NC2-T3A-T2+NSB:NC3=-T3A+T2A+T1+NSA:NC4=NSA*T3 




X 
Y 

IS-IS+1 
NEXT 
16900 NEXT 
16902 GOTO 16924 
16904 FOR IIS-XNC+1 TO XXS 


NCI*XC(IIS-1)+NC2*XC(IIS)+NC3*XC(IIS+1)+NC4*XC(IIS+2) 
NC1*YC(lIS-1)+NC2*YC(IIS)+NC3*YC(IIS+1)+NC4*YC(IIS+2) 


16906 

16908 

16910 

16912 

16914 

16916 

16918 

16920 


FOR T-0 TO 1 STEP NBS 

T1-.5*T:T2-T*T:T2A-.5*T2:T3-T2*T:T3A-T3/2 
NC1—NSA*T3+T2A-T1+NSA:NC2-T3A-T2+NSB:NC3- 


-T3A+T2A+T1+NSA:NC4«NSA*T3 


X(IS)-NC1*XC(IIS-1 
Y(IS)»NC1*YC(IIS-1 
Z(IS)*NC1*ZC(IIS-1 
IS-IS+1 
NEXT 
16922 NEXT 
16924 XNS-IS 

16926 IF XBSDR THEN 16936 
16928 PSET(X(XNP),Y(XNP)),QBS 
16930 FOR II-XNP TO XNP+XNS-1 
16932 LINE —(X(II),Y(II)),QBS 
16934 NEXT 
16936 RETURN 
16960 * Bezier2.SUB 
16962 * 


+NC2*XC(IIS)+NC3*XC(IIS+1)+NC4*XC(IIS+2) 
+NC2*YC(IIS)+NC3*YC(IIS+1)+NC4*YC(IIS+2) 
+NC2*ZC(IIS)+NC3*ZC(IIS+1)+NC4*ZC(IIS+2) 


Set pixel, x,y color QBS 


*- Line from last X,Y to 

■XI,Y1 color QBS 


Steve Enns Dec.22 
From Fund, of Int 


1984 

CG. p.519 


16964 

16966 

16968 

16970 

16972 

16974 

16976 

16978 


Calculates cubic parametric free-form Bezier curves 
XBS23-1 for 3d else 2d 

XBZDR-0 Is the curve is to be drawn (2d only) 

XC(),YC(),[ ZC() ] are the hull points (4 per curve) 
XNC is the Index of first control point 
XNB is the number of control points to be used 
XNP is the index for the first curve point 


( continued ) 
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16980 ' N6S Is the step size (defoult provided) 

16982 * QBZ Is the color If drown 

16984 * Returns X(),Y(),[ Z() ] as the points 

16986 * Returns XNS as the Index of the last curve point 

16988 * 

16990 IS-XNP:XXS-XNC+XNB-1 
16992 IF NBS-0 THEN NBS-.1 

16994 IF XBS23 THEN 17016 

16996 FOR IIS-XNC TO XXS STEP 4 
16998 FOR T-0 TO 1+NBS STEP NBS 
17000 T2«T*T:T3«T2*T 

17002 NC1-1-3*T+3*T2-T3:NC2-3*T3-6*T2+3*T:NC3«3*T2-3*T3:NC4-T3 

17004 X(IS)-NC1*XC(IIS)+NC2*XC(IIS+1)+NC3*XC(IIS+2)+NC4*XC(IIS+3) 

17006 Y(IS)-NC1*YC(IIS)+NC2*YC(IIS+1)+NC3*YC(lIS+2)+NC4*YC(IIS+3) 

17008 IS-IS+1 

17010 NEXT 

17012 NEXT 

17014 GOTO 17036 

17016 FOR IIS-XNC TO XXS STEP 4 

17018 FOR T-0 TO 1+NBS STEP NBS 

17020 T2-T*T:T3-T2*T 

17022 NC1-1-3*T+3*T2-T3:NC2«3*T3-6*T2+3*T:NC3«3*T2-3*T3:NC4-T3 

17024 X(IS)»NC1*XC(IIS)+NC2*XC(IIS+1)+NC3*XC(IIS+2)+NC4*XC(IIS+3) 

17026 Y(IS)«NC1*YC(IIS)+NC2*YC(IIS+1)+NC3*YC(IIS+2)+NC4*YC(IIS+3) 

17028 Z(IS)-NC1*ZC(IIS)+NC2*ZC(IIS+1)+NC3*ZC(IIS+2)+NC4*ZC(IIS+3) 

17030 IS-IS+1 

17032 NEXT 

17034 NEXT 

17036 XNS-IS-1 

17038 IF XBZDR THEN 17048 

17040 PSET(X(XNP),Y(XNP)),QBZ ’- Pixel at x,y color QBZ 

17042 FOR II-XNP TO XNP+XNS 

17044 LINE -(X(II),Y(II)),QBZ • Line from last X,Y to 

17046 NEXT ’XI,Y1 color QBZ 

17048 RETURN 


READ.ME 

"Free-Form Curves On Your Micro," by Steve Enns, December 1986, page 225. 


This diskette Is to accompany the article with 

BYTE ID# 507097, "Free-form Curves on Your Micro", 

submitted by: Steve Enns 

2425 Haul tain Ave. 

Saskatoon, Sask. 

Canada 
S7J 1R2 
304-343-8158 


The files on this disk are: CURVTEST.BAS 

BSPLINE.SUB 
BEZIER2.SUB 

and are all written In MS-BASIC 1.2 . 

CURVTEST.BAS is a practice program written for the Texas 
Instruments Professional Computer, which will require 
SLIGHT modification to run on an IBM PC, under MS-BASIC. 

BSPLINE.SUB and BEZIER2.SUB are subroutines which are 
used by CURVTEST.BAS and may be merged into other programs. 
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DISKS AND DOWNLOADS 


Ordering Disks of byte Listings 

Listings that accompany BYTE articles are 
available in a variety of disk formats and on 
Cauzin Softstrip. Each disk package (which 
sometimes consists of more than one disk) con¬ 
tains an entire month’s listings. If you want to 
order a disk package from a previous month, 
please call (603) 924-9281 to find out how many 
disks it includes. To order listings (for noncom¬ 
mercial use only), fill out this form and send a 
check or money order in the correct amount to: 

BYTE Listings 

One Phoenix Mill Lane 

Peterborough. NH 03458 

All prices include postage. Program listings can 
also be downloaded via BYTEnet Listings at 
(617) 861-6764. 

BYTE issue: _ 


COMMON 5'/HNCH FORMATS 

All cost $8.95, $10.95 outside U.S.A. Annual 

subscription is $69.95. $89.95 outside U.S.A. 

□ Apple II 

□ IBM PC 

□ Kaypro 2 CP/M 

□ MS-DOS 8 Sector 

□ Texas Instruments Professional 

□ TRS-80 Model 4 

COMMON 316-INCH FORMATS 

All cost $9.95, $11.95 outside U.S.A. Annual 

subscription is $79.95, $99.95 outside U.S.A. 

□ Apple Macintosh 

□ Atari 520ST 

□ Amiga 

□ Hewlett-Packard 150 


SEND TO: 

Name_ 

Street_ 

City_State or Province 

Postal Code_Country_ 

Check or money order enclosed for $_ 


Bulletin Boards in Canada 

Listed below are some computer bulletin boards 
that carry program listings from BYTE. Programs 
are for noncommercial use in connection with 
BYTE articles only. Some BBSs may charge an 
annual maintenance fee. and you must pay your 
own telephone charges. 

Western Canadian Distribution Center (3420 48th 
St., Edmonton. Alberta T6L 3R5) will be supplying 
listings to its member bulletin board systems. 

Edmonton, Alberta, (403) 454-6093 
Meadowlark, Alberta. (403) 435-6579 
Montreal, Quebec. PComm Systems, (514) 989-9450 
Prince George, British Columbia, (604) 562-9519 
Regina, Saskatchewan, (306) 586-5585 
Canadian Remote Systems. Toronto 

Toronto, Ontario, Epson Club of Toronto lEPCCTT) 
(416) 635-9600 

Winnipeg. Manitoba, (204) 452-5529 

In addition, arrangements for BYTEnet Listings have 
been made with one or more system operators in 
the following nations: Australia. Austria. Brazil. Den¬ 
mark. France. Hong Kong. Indonesia. Italy, lapan. 
Malaysia. The Netherlands, Nigeria. Norway. Saudi 
Arabia, Singapore, Sweden. Switzerland, United 
Kingdom, and West Germany. Contact us at (603) 
924-9281 for an up-to-date list. ■ 
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EDITORIAL CALENDAR 


1987 


May — DESKTOP PUBLISHING: An exploration of the hardware and software needed for desktop publishing, 
from page description languages to high-resolution printers and typesetting back ends. 

lUNE — COMPUTER-AIDED DESIGN: The anatomy of computer-aided design/drafting software, the graphics 
display devices needed for CAD. and the data structures used by CAD programs to export data to other 


applications. 


JULY — Local Area NETWORKS: The technology of linking personal computers together to share data 
files, programs, and peripheral devices. 

AUGUST — PROLOG: A look at logic programming with articles on tips and techniques and explorations of 
the tasks Prolog is best suited for. 

SEPTEMBER — PRINTER TECHNOLOGIES: An examination of the state of the art in printer technologies, 
including laser, liquid-crystal shutter, and ink-jet technologies. 

OCTOBER — HEURISTIC ALGORITHMS: Artificial intelligence techniques for giving computers the ability 
to learn from experience. 

November — High-Performance Workstations: a tour of the technology underlying the work¬ 
stations used by scientists and engineers in computer-aided engineering/design. 

December — Natural Language Processing: The technology of getting computers to under¬ 
stand the natural language of man. 



JANUARY — MANAGING MEGABYTES: Looking at the ways computers store and retrieve data in situations 
where disk space is measured in gigabytes and memory is measured in megabytes. Also a look at the 
new applications that mega-memory and storage will permit. 

FEBRUARY — LISP: A BYTE reexamination of the original language of artificial intelligence research. 

March — Floating-Point Processors: a look at the processors that speed the computation of 
mathematical operations in personal computers, including coprocessors and array processors. 

April — Memory Management The hardware and software issues in managing a personal computer s 
memory space. 

May — CPU ARCHITECTURES: An exploration of the latest 32-bit microprocessors, including digital signal 
processors and programmable graphics processors. 
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Announcing BYTE s 
New Subscriber Benefits 

Program 


^^our BYTE subscription brings 
you a complete diet of the latest in 
microcomputer technology every 
30 days. The kind of broad-based 
objective coverage you read in 
every issue. In addition, your 
subscription carries a wealth of 
other benefits. Check the check 
list: 

DISCOUNTS 

13 issues instead of 12 if you 
send payment with subscription 
order. 

[2f One-year subscription at $21 
(50% off cover price). 

Two-year subscription at $38. 

Three-year subscription at $55. 

One-year GROUP subscripc.or. 
for ten or more at Sl~.50 each. 
(Call or write for details. 

SERVICES 

BIX: BYTE’s Information 
Exchange puts you on-line 24 
hours a day with your peers 
via computer conferencing and 
electronic mail. All you need *> 
sign up is a microcomputer, a 
modem, and telecomm 
software. 

^f Reader Service: For information 
on products advertised in 
BYTE, circle the numbers on 
the Reader Service card 
enclosed in each issue that 
correspond to the numbers for 
the advertisers you select. Drop 
it in the mail and we’ll get 
your inquiries to the advertisers. 

$j TIPS: BYTE’s Telephone 
Inquiry System is available to 



subscribers who need fast 
response. After obtaining your 
Subscriber I.D. Card, dial TIPS 
and enter your inquiries. You’ll 
save as much as ten days over 
the response to Reader Service 
cards. 

if Disks and Downloads: 

Listings of programs that 
accompany BYTE articles are 
now available free on the 
BYTEnet bulletin board, and 
cm disk or in quarterly printed 
supplements. 

ij Microform: BYTE is available 
in microform from University 
Microfilm International in the 
U.S. and Europe. 

^ BYTE’s BOMB: BYTE’s 
Ongoing Monitor Box is your 
direct line to the editor’s desk. 
Each month, you can rate the 
articles via the Reader Service 
card. Your feedback helps us 


keep up to date on your 
information needs. 

^ Customer Service: If you have 
a problem with, or a question 
about, your subscription, you 
may phone us during regular 
business hours (Eastern time 
at our toll-free number: 800- 
258-5485. You can also use 
Customer Service to obtain 
back issues and editorial indexes. 

BONUSES 

2 Annual Separate Issues: In 
addition to BYTE's 12 mcnUf 
issues, subscribers also rccehr 
our annual IBM PC issue free 
of charge, as well as any other 
annual issues BYTE may 
produce. 

0 BYTE Deck: Subscribers 
receive five BYTE postcard 
deck mailings each year—a 
direct response system for you 
to obtain information on 
advertised products through 
return mail. 

To be on the leading edge of 
microcomputer technology and 
receive all the aforementioned 
benefits, make a career decision 
today. Call roll-free weekdays, 
8:30am to 4:30pm Eastern time: 
800-258-5485. 

And. . . welcome to 
BYTE country! 


S' 

fi 



EVIi 

the small systems journal 













^ Eureka: 


The Solver 


A nyone and 
everyone who 
routinely works with 
equations needs 
Eureka: The Solver 

It solves the most com¬ 
plex equations in seconds. 
Whether you're a scientist, 
engineer, financial analyst, 
student, teacher, or some 
other professional, you 
need Eureka: The Solver! 

Any problem that can be 
expressed as a linear or non-linear 
equation can be solved with Eureka. 
Algebra, Trigonometry and Calculus 
problems are a snap. 

Eureka: The Solver also handles 
maximization and minimization 
problems, does plot functions, 
generates reports, and saves you 
an incredible amount of time. 

X+exp(X) = 10 
solved instantly instead 
of eventually! 

Imagine you have to "solve 
for X," where X + explX) = 10, and 
you don’t have Eureka: The Solver. 
What you do have is a problem, 
because it's going to take a lot of 
time guessing at "X." Maybe your 
guesses get closer and closer to the 
right answer, but it’s also getting 
closer and closer to midnight and 
you're doing it the hard way. 

With Eureka: The Solver, there's 
no guessing, no dancing in the dark— 
you get the right answer, right 
now. (PS: X = 2.0705799, and 
Eureka solved that one in .4 
of a second!) 


System requirements 

IBM PC, AT, XT, Portable. 3270 or true compatibles. 
PC-DOS (MS-DOS) 2.0 and later. 384K 


How to use Eureka: 

The Solver 

It's easy. 

1. Enter your equation into 
the full-screen editor 

2. Select the "Solve" command 

3. Look at the answer 

4. You're done 

You can then tell Eureka to 

■ Evaluate your solution 

■ Plot a graph 

■ Generate a report, then send the 
output to your printer, disk file 
or screen 

■ Or all of the above 


Eureka: The Solver includes 

Ef A full-screen editor 
Ef Pull-down menus 
Context-sensitive Help 
Ef On-screen calculator 
Ef Automatic 8087 math 
co-processor chip support 
E Powerful financial functions 
Ef Built-in and user-defined 
math and financial functions 
Ef Ability to generate reports 
complete with plots and lists 
(3 Polynomial finder 
0 Inequality solutions 


Some of Eureka's 
key features 

You can key in: 

Ef A formula or formulas 
Ef A series of equations—and 
solve for all variables 
Ef Constraints Hike X has to be 
< or = 2) 

Ef A function to plot 
EJ Unit conversions 
g Maximization and minimization 
problems 

0 Interest Rate/Present Value 
calculations 

Ef Variables we call “What hap¬ 
pens?" like "What happens if I 
change this variable to 21 and 
that variable to 27?" 


•Introductory price—good through July 1,1987 


only 



BORLAND 

INTERNATIONAL 


4585 scons VALLEY DRIVE SCOTTS VALLEY. CA 95G66 (408) 438-8400 TELEX 172373 

E15 


For the dealer nearest you or to order by phone call 

(800)255-8008 

in CA (800) 742-1133 in Canada (800) 237-1136 



All this power for only 
$99.95! 

Equation-solving used to be a 
mainframe problem, but we've 
solved that problem. 

Eureka: The Solver is all you 
need—and it's yours for only 
$99.95! 

That kind of savings you can 
calculate with your fingers! 

Eureka The Solver is a trademark, of Borland international, Inc 
IBM. AT. and XT are registered trademarks of international 
Business Machines Corp MS-DOS is a registered trademark of 
Microsoft Corp Copyright 1987 Borland International 









